sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (c) 1991-2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
  12  */
  13
  14 #include "EXTERN.h"
  15 #define PERL_IN_SV_C
  16 #include "perl.h"
  17
  18 #define FCALL *f
  19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
  20
  21 static void do_report_used(pTHXo_ SV *sv);
  22 static void do_clean_objs(pTHXo_ SV *sv);
  23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
  24 static void do_clean_named_objs(pTHXo_ SV *sv);
  25 #endif
  26 static void do_clean_all(pTHXo_ SV *sv);
  27
  28 /*
  29  * "A time to plant, and a time to uproot what was planted..."
  30  */
  31
  32 #define plant_SV(p) \
  33     STMT_START {                                        \
  34         SvANY(p) = (void *)PL_sv_root;                  \
  35         SvFLAGS(p) = SVTYPEMASK;                        \
  36         PL_sv_root = (p);                               \
  37         --PL_sv_count;                                  \
  38     } STMT_END
  39
  40 /* sv_mutex must be held while calling uproot_SV() */
  41 #define uproot_SV(p) \
  42     STMT_START {                                        \
  43         (p) = PL_sv_root;                               \
  44         PL_sv_root = (SV*)SvANY(p);                     \
  45         ++PL_sv_count;                                  \
  46     } STMT_END
  47
  48 #define new_SV(p) \
  49     STMT_START {                                        \
  50         LOCK_SV_MUTEX;                                  \
  51         if (PL_sv_root)                                 \
  52             uproot_SV(p);                               \
  53         else                                            \
  54             (p) = more_sv();                            \
  55         UNLOCK_SV_MUTEX;                                \
  56         SvANY(p) = 0;                                   \
  57         SvREFCNT(p) = 1;                                \
  58         SvFLAGS(p) = 0;                                 \
  59     } STMT_END
  60
  61 #ifdef DEBUGGING
  62
  63 #define del_SV(p) \
  64     STMT_START {                                        \
  65         LOCK_SV_MUTEX;                                  \
  66         if (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     XPV *arena, *arenanext;
 198
 199     /* Free arenas here, but be careful about fake ones.  (We assume
 200        contiguity of the fake ones with the corresponding real ones.) */
 201
 202     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 203         svanext = (SV*) SvANY(sva);
 204         while (svanext && SvFAKE(svanext))
 205             svanext = (SV*) SvANY(svanext);
 206
 207         if (!SvFAKE(sva))
 208             Safefree((void *)sva);
 209     }
 210
 211     for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
 212         arenanext = (XPV*)arena->xpv_pv;
 213         Safefree(arena);
 214     }
 215     PL_xiv_arenaroot = 0;
 216
 217     for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
 218         arenanext = (XPV*)arena->xpv_pv;
 219         Safefree(arena);
 220     }
 221     PL_xnv_arenaroot = 0;
 222
 223     for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
 224         arenanext = (XPV*)arena->xpv_pv;
 225         Safefree(arena);
 226     }
 227     PL_xrv_arenaroot = 0;
 228
 229     for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
 230         arenanext = (XPV*)arena->xpv_pv;
 231         Safefree(arena);
 232     }
 233     PL_xpv_arenaroot = 0;
 234
 235     for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
 236         arenanext = (XPV*)arena->xpv_pv;
 237         Safefree(arena);
 238     }
 239     PL_xpviv_arenaroot = 0;
 240
 241     for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
 242         arenanext = (XPV*)arena->xpv_pv;
 243         Safefree(arena);
 244     }
 245     PL_xpvnv_arenaroot = 0;
 246
 247     for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
 248         arenanext = (XPV*)arena->xpv_pv;
 249         Safefree(arena);
 250     }
 251     PL_xpvcv_arenaroot = 0;
 252
 253     for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
 254         arenanext = (XPV*)arena->xpv_pv;
 255         Safefree(arena);
 256     }
 257     PL_xpvav_arenaroot = 0;
 258
 259     for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
 260         arenanext = (XPV*)arena->xpv_pv;
 261         Safefree(arena);
 262     }
 263     PL_xpvhv_arenaroot = 0;
 264
 265     for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
 266         arenanext = (XPV*)arena->xpv_pv;
 267         Safefree(arena);
 268     }
 269     PL_xpvmg_arenaroot = 0;
 270
 271     for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
 272         arenanext = (XPV*)arena->xpv_pv;
 273         Safefree(arena);
 274     }
 275     PL_xpvlv_arenaroot = 0;
 276
 277     for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
 278         arenanext = (XPV*)arena->xpv_pv;
 279         Safefree(arena);
 280     }
 281     PL_xpvbm_arenaroot = 0;
 282
 283     for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
 284         arenanext = (XPV*)arena->xpv_pv;
 285         Safefree(arena);
 286     }
 287     PL_he_arenaroot = 0;
 288
 289     if (PL_nice_chunk)
 290         Safefree(PL_nice_chunk);
 291     PL_nice_chunk = Nullch;
 292     PL_nice_chunk_size = 0;
 293     PL_sv_arenaroot = 0;
 294     PL_sv_root = 0;
 295 }
 296
 297 void
 298 Perl_report_uninit(pTHX)
 299 {
 300     if (PL_op)
 301         Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
 302                     " in ", PL_op_desc[PL_op->op_type]);
 303     else
 304         Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
 305 }
 306
 307 STATIC XPVIV*
 308 S_new_xiv(pTHX)
 309 {
 310     IV* xiv;
 311     LOCK_SV_MUTEX;
 312     if (!PL_xiv_root)
 313         more_xiv();
 314     xiv = PL_xiv_root;
 315     /*
 316      * See comment in more_xiv() -- RAM.
 317      */
 318     PL_xiv_root = *(IV**)xiv;
 319     UNLOCK_SV_MUTEX;
 320     return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
 321 }
 322
 323 STATIC void
 324 S_del_xiv(pTHX_ XPVIV *p)
 325 {
 326     IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
 327     LOCK_SV_MUTEX;
 328     *(IV**)xiv = PL_xiv_root;
 329     PL_xiv_root = xiv;
 330     UNLOCK_SV_MUTEX;
 331 }
 332
 333 STATIC void
 334 S_more_xiv(pTHX)
 335 {
 336     register IV* xiv;
 337     register IV* xivend;
 338     XPV* ptr;
 339     New(705, ptr, 1008/sizeof(XPV), XPV);
 340     ptr->xpv_pv = (char*)PL_xiv_arenaroot;              /* linked list of xiv arenas */
 341     PL_xiv_arenaroot = ptr;                     /* to keep Purify happy */
 342
 343     xiv = (IV*) ptr;
 344     xivend = &xiv[1008 / sizeof(IV) - 1];
 345     xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1;   /* fudge by size of XPV */
 346     PL_xiv_root = xiv;
 347     while (xiv < xivend) {
 348         *(IV**)xiv = (IV *)(xiv + 1);
 349         xiv++;
 350     }
 351     *(IV**)xiv = 0;
 352 }
 353
 354 STATIC XPVNV*
 355 S_new_xnv(pTHX)
 356 {
 357     NV* xnv;
 358     LOCK_SV_MUTEX;
 359     if (!PL_xnv_root)
 360         more_xnv();
 361     xnv = PL_xnv_root;
 362     PL_xnv_root = *(NV**)xnv;
 363     UNLOCK_SV_MUTEX;
 364     return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
 365 }
 366
 367 STATIC void
 368 S_del_xnv(pTHX_ XPVNV *p)
 369 {
 370     NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
 371     LOCK_SV_MUTEX;
 372     *(NV**)xnv = PL_xnv_root;
 373     PL_xnv_root = xnv;
 374     UNLOCK_SV_MUTEX;
 375 }
 376
 377 STATIC void
 378 S_more_xnv(pTHX)
 379 {
 380     register NV* xnv;
 381     register NV* xnvend;
 382     XPV *ptr;
 383     New(711, ptr, 1008/sizeof(XPV), XPV);
 384     ptr->xpv_pv = (char*)PL_xnv_arenaroot;
 385     PL_xnv_arenaroot = ptr;
 386
 387     xnv = (NV*) ptr;
 388     xnvend = &xnv[1008 / sizeof(NV) - 1];
 389     xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
 390     PL_xnv_root = xnv;
 391     while (xnv < xnvend) {
 392         *(NV**)xnv = (NV*)(xnv + 1);
 393         xnv++;
 394     }
 395     *(NV**)xnv = 0;
 396 }
 397
 398 STATIC XRV*
 399 S_new_xrv(pTHX)
 400 {
 401     XRV* xrv;
 402     LOCK_SV_MUTEX;
 403     if (!PL_xrv_root)
 404         more_xrv();
 405     xrv = PL_xrv_root;
 406     PL_xrv_root = (XRV*)xrv->xrv_rv;
 407     UNLOCK_SV_MUTEX;
 408     return xrv;
 409 }
 410
 411 STATIC void
 412 S_del_xrv(pTHX_ XRV *p)
 413 {
 414     LOCK_SV_MUTEX;
 415     p->xrv_rv = (SV*)PL_xrv_root;
 416     PL_xrv_root = p;
 417     UNLOCK_SV_MUTEX;
 418 }
 419
 420 STATIC void
 421 S_more_xrv(pTHX)
 422 {
 423     register XRV* xrv;
 424     register XRV* xrvend;
 425     XPV *ptr;
 426     New(712, ptr, 1008/sizeof(XPV), XPV);
 427     ptr->xpv_pv = (char*)PL_xrv_arenaroot;
 428     PL_xrv_arenaroot = ptr;
 429
 430     xrv = (XRV*) ptr;
 431     xrvend = &xrv[1008 / sizeof(XRV) - 1];
 432     xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
 433     PL_xrv_root = xrv;
 434     while (xrv < xrvend) {
 435         xrv->xrv_rv = (SV*)(xrv + 1);
 436         xrv++;
 437     }
 438     xrv->xrv_rv = 0;
 439 }
 440
 441 STATIC XPV*
 442 S_new_xpv(pTHX)
 443 {
 444     XPV* xpv;
 445     LOCK_SV_MUTEX;
 446     if (!PL_xpv_root)
 447         more_xpv();
 448     xpv = PL_xpv_root;
 449     PL_xpv_root = (XPV*)xpv->xpv_pv;
 450     UNLOCK_SV_MUTEX;
 451     return xpv;
 452 }
 453
 454 STATIC void
 455 S_del_xpv(pTHX_ XPV *p)
 456 {
 457     LOCK_SV_MUTEX;
 458     p->xpv_pv = (char*)PL_xpv_root;
 459     PL_xpv_root = p;
 460     UNLOCK_SV_MUTEX;
 461 }
 462
 463 STATIC void
 464 S_more_xpv(pTHX)
 465 {
 466     register XPV* xpv;
 467     register XPV* xpvend;
 468     New(713, xpv, 1008/sizeof(XPV), XPV);
 469     xpv->xpv_pv = (char*)PL_xpv_arenaroot;
 470     PL_xpv_arenaroot = xpv;
 471
 472     xpvend = &xpv[1008 / sizeof(XPV) - 1];
 473     PL_xpv_root = ++xpv;
 474     while (xpv < xpvend) {
 475         xpv->xpv_pv = (char*)(xpv + 1);
 476         xpv++;
 477     }
 478     xpv->xpv_pv = 0;
 479 }
 480
 481 STATIC XPVIV*
 482 S_new_xpviv(pTHX)
 483 {
 484     XPVIV* xpviv;
 485     LOCK_SV_MUTEX;
 486     if (!PL_xpviv_root)
 487         more_xpviv();
 488     xpviv = PL_xpviv_root;
 489     PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
 490     UNLOCK_SV_MUTEX;
 491     return xpviv;
 492 }
 493
 494 STATIC void
 495 S_del_xpviv(pTHX_ XPVIV *p)
 496 {
 497     LOCK_SV_MUTEX;
 498     p->xpv_pv = (char*)PL_xpviv_root;
 499     PL_xpviv_root = p;
 500     UNLOCK_SV_MUTEX;
 501 }
 502
 503 STATIC void
 504 S_more_xpviv(pTHX)
 505 {
 506     register XPVIV* xpviv;
 507     register XPVIV* xpvivend;
 508     New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
 509     xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
 510     PL_xpviv_arenaroot = xpviv;
 511
 512     xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
 513     PL_xpviv_root = ++xpviv;
 514     while (xpviv < xpvivend) {
 515         xpviv->xpv_pv = (char*)(xpviv + 1);
 516         xpviv++;
 517     }
 518     xpviv->xpv_pv = 0;
 519 }
 520
 521 STATIC XPVNV*
 522 S_new_xpvnv(pTHX)
 523 {
 524     XPVNV* xpvnv;
 525     LOCK_SV_MUTEX;
 526     if (!PL_xpvnv_root)
 527         more_xpvnv();
 528     xpvnv = PL_xpvnv_root;
 529     PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
 530     UNLOCK_SV_MUTEX;
 531     return xpvnv;
 532 }
 533
 534 STATIC void
 535 S_del_xpvnv(pTHX_ XPVNV *p)
 536 {
 537     LOCK_SV_MUTEX;
 538     p->xpv_pv = (char*)PL_xpvnv_root;
 539     PL_xpvnv_root = p;
 540     UNLOCK_SV_MUTEX;
 541 }
 542
 543 STATIC void
 544 S_more_xpvnv(pTHX)
 545 {
 546     register XPVNV* xpvnv;
 547     register XPVNV* xpvnvend;
 548     New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
 549     xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
 550     PL_xpvnv_arenaroot = xpvnv;
 551
 552     xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
 553     PL_xpvnv_root = ++xpvnv;
 554     while (xpvnv < xpvnvend) {
 555         xpvnv->xpv_pv = (char*)(xpvnv + 1);
 556         xpvnv++;
 557     }
 558     xpvnv->xpv_pv = 0;
 559 }
 560
 561 STATIC XPVCV*
 562 S_new_xpvcv(pTHX)
 563 {
 564     XPVCV* xpvcv;
 565     LOCK_SV_MUTEX;
 566     if (!PL_xpvcv_root)
 567         more_xpvcv();
 568     xpvcv = PL_xpvcv_root;
 569     PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
 570     UNLOCK_SV_MUTEX;
 571     return xpvcv;
 572 }
 573
 574 STATIC void
 575 S_del_xpvcv(pTHX_ XPVCV *p)
 576 {
 577     LOCK_SV_MUTEX;
 578     p->xpv_pv = (char*)PL_xpvcv_root;
 579     PL_xpvcv_root = p;
 580     UNLOCK_SV_MUTEX;
 581 }
 582
 583 STATIC void
 584 S_more_xpvcv(pTHX)
 585 {
 586     register XPVCV* xpvcv;
 587     register XPVCV* xpvcvend;
 588     New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
 589     xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
 590     PL_xpvcv_arenaroot = xpvcv;
 591
 592     xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
 593     PL_xpvcv_root = ++xpvcv;
 594     while (xpvcv < xpvcvend) {
 595         xpvcv->xpv_pv = (char*)(xpvcv + 1);
 596         xpvcv++;
 597     }
 598     xpvcv->xpv_pv = 0;
 599 }
 600
 601 STATIC XPVAV*
 602 S_new_xpvav(pTHX)
 603 {
 604     XPVAV* xpvav;
 605     LOCK_SV_MUTEX;
 606     if (!PL_xpvav_root)
 607         more_xpvav();
 608     xpvav = PL_xpvav_root;
 609     PL_xpvav_root = (XPVAV*)xpvav->xav_array;
 610     UNLOCK_SV_MUTEX;
 611     return xpvav;
 612 }
 613
 614 STATIC void
 615 S_del_xpvav(pTHX_ XPVAV *p)
 616 {
 617     LOCK_SV_MUTEX;
 618     p->xav_array = (char*)PL_xpvav_root;
 619     PL_xpvav_root = p;
 620     UNLOCK_SV_MUTEX;
 621 }
 622
 623 STATIC void
 624 S_more_xpvav(pTHX)
 625 {
 626     register XPVAV* xpvav;
 627     register XPVAV* xpvavend;
 628     New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
 629     xpvav->xav_array = (char*)PL_xpvav_arenaroot;
 630     PL_xpvav_arenaroot = xpvav;
 631
 632     xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
 633     PL_xpvav_root = ++xpvav;
 634     while (xpvav < xpvavend) {
 635         xpvav->xav_array = (char*)(xpvav + 1);
 636         xpvav++;
 637     }
 638     xpvav->xav_array = 0;
 639 }
 640
 641 STATIC XPVHV*
 642 S_new_xpvhv(pTHX)
 643 {
 644     XPVHV* xpvhv;
 645     LOCK_SV_MUTEX;
 646     if (!PL_xpvhv_root)
 647         more_xpvhv();
 648     xpvhv = PL_xpvhv_root;
 649     PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
 650     UNLOCK_SV_MUTEX;
 651     return xpvhv;
 652 }
 653
 654 STATIC void
 655 S_del_xpvhv(pTHX_ XPVHV *p)
 656 {
 657     LOCK_SV_MUTEX;
 658     p->xhv_array = (char*)PL_xpvhv_root;
 659     PL_xpvhv_root = p;
 660     UNLOCK_SV_MUTEX;
 661 }
 662
 663 STATIC void
 664 S_more_xpvhv(pTHX)
 665 {
 666     register XPVHV* xpvhv;
 667     register XPVHV* xpvhvend;
 668     New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
 669     xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
 670     PL_xpvhv_arenaroot = xpvhv;
 671
 672     xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
 673     PL_xpvhv_root = ++xpvhv;
 674     while (xpvhv < xpvhvend) {
 675         xpvhv->xhv_array = (char*)(xpvhv + 1);
 676         xpvhv++;
 677     }
 678     xpvhv->xhv_array = 0;
 679 }
 680
 681 STATIC XPVMG*
 682 S_new_xpvmg(pTHX)
 683 {
 684     XPVMG* xpvmg;
 685     LOCK_SV_MUTEX;
 686     if (!PL_xpvmg_root)
 687         more_xpvmg();
 688     xpvmg = PL_xpvmg_root;
 689     PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
 690     UNLOCK_SV_MUTEX;
 691     return xpvmg;
 692 }
 693
 694 STATIC void
 695 S_del_xpvmg(pTHX_ XPVMG *p)
 696 {
 697     LOCK_SV_MUTEX;
 698     p->xpv_pv = (char*)PL_xpvmg_root;
 699     PL_xpvmg_root = p;
 700     UNLOCK_SV_MUTEX;
 701 }
 702
 703 STATIC void
 704 S_more_xpvmg(pTHX)
 705 {
 706     register XPVMG* xpvmg;
 707     register XPVMG* xpvmgend;
 708     New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
 709     xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
 710     PL_xpvmg_arenaroot = xpvmg;
 711
 712     xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
 713     PL_xpvmg_root = ++xpvmg;
 714     while (xpvmg < xpvmgend) {
 715         xpvmg->xpv_pv = (char*)(xpvmg + 1);
 716         xpvmg++;
 717     }
 718     xpvmg->xpv_pv = 0;
 719 }
 720
 721 STATIC XPVLV*
 722 S_new_xpvlv(pTHX)
 723 {
 724     XPVLV* xpvlv;
 725     LOCK_SV_MUTEX;
 726     if (!PL_xpvlv_root)
 727         more_xpvlv();
 728     xpvlv = PL_xpvlv_root;
 729     PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
 730     UNLOCK_SV_MUTEX;
 731     return xpvlv;
 732 }
 733
 734 STATIC void
 735 S_del_xpvlv(pTHX_ XPVLV *p)
 736 {
 737     LOCK_SV_MUTEX;
 738     p->xpv_pv = (char*)PL_xpvlv_root;
 739     PL_xpvlv_root = p;
 740     UNLOCK_SV_MUTEX;
 741 }
 742
 743 STATIC void
 744 S_more_xpvlv(pTHX)
 745 {
 746     register XPVLV* xpvlv;
 747     register XPVLV* xpvlvend;
 748     New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
 749     xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
 750     PL_xpvlv_arenaroot = xpvlv;
 751
 752     xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
 753     PL_xpvlv_root = ++xpvlv;
 754     while (xpvlv < xpvlvend) {
 755         xpvlv->xpv_pv = (char*)(xpvlv + 1);
 756         xpvlv++;
 757     }
 758     xpvlv->xpv_pv = 0;
 759 }
 760
 761 STATIC XPVBM*
 762 S_new_xpvbm(pTHX)
 763 {
 764     XPVBM* xpvbm;
 765     LOCK_SV_MUTEX;
 766     if (!PL_xpvbm_root)
 767         more_xpvbm();
 768     xpvbm = PL_xpvbm_root;
 769     PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
 770     UNLOCK_SV_MUTEX;
 771     return xpvbm;
 772 }
 773
 774 STATIC void
 775 S_del_xpvbm(pTHX_ XPVBM *p)
 776 {
 777     LOCK_SV_MUTEX;
 778     p->xpv_pv = (char*)PL_xpvbm_root;
 779     PL_xpvbm_root = p;
 780     UNLOCK_SV_MUTEX;
 781 }
 782
 783 STATIC void
 784 S_more_xpvbm(pTHX)
 785 {
 786     register XPVBM* xpvbm;
 787     register XPVBM* xpvbmend;
 788     New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
 789     xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
 790     PL_xpvbm_arenaroot = xpvbm;
 791
 792     xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
 793     PL_xpvbm_root = ++xpvbm;
 794     while (xpvbm < xpvbmend) {
 795         xpvbm->xpv_pv = (char*)(xpvbm + 1);
 796         xpvbm++;
 797     }
 798     xpvbm->xpv_pv = 0;
 799 }
 800
 801 #ifdef LEAKTEST
 802 #  define my_safemalloc(s)      (void*)safexmalloc(717,s)
 803 #  define my_safefree(p)        safexfree((char*)p)
 804 #else
 805 #  define my_safemalloc(s)      (void*)safemalloc(s)
 806 #  define my_safefree(p)        safefree((char*)p)
 807 #endif
 808
 809 #ifdef PURIFY
 810
 811 #define new_XIV()       my_safemalloc(sizeof(XPVIV))
 812 #define del_XIV(p)      my_safefree(p)
 813
 814 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
 815 #define del_XNV(p)      my_safefree(p)
 816
 817 #define new_XRV()       my_safemalloc(sizeof(XRV))
 818 #define del_XRV(p)      my_safefree(p)
 819
 820 #define new_XPV()       my_safemalloc(sizeof(XPV))
 821 #define del_XPV(p)      my_safefree(p)
 822
 823 #define new_XPVIV()     my_safemalloc(sizeof(XPVIV))
 824 #define del_XPVIV(p)    my_safefree(p)
 825
 826 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
 827 #define del_XPVNV(p)    my_safefree(p)
 828
 829 #define new_XPVCV()     my_safemalloc(sizeof(XPVCV))
 830 #define del_XPVCV(p)    my_safefree(p)
 831
 832 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
 833 #define del_XPVAV(p)    my_safefree(p)
 834
 835 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
 836 #define del_XPVHV(p)    my_safefree(p)
 837
 838 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
 839 #define del_XPVMG(p)    my_safefree(p)
 840
 841 #define new_XPVLV()     my_safemalloc(sizeof(XPVLV))
 842 #define del_XPVLV(p)    my_safefree(p)
 843
 844 #define new_XPVBM()     my_safemalloc(sizeof(XPVBM))
 845 #define del_XPVBM(p)    my_safefree(p)
 846
 847 #else /* !PURIFY */
 848
 849 #define new_XIV()       (void*)new_xiv()
 850 #define del_XIV(p)      del_xiv((XPVIV*) p)
 851
 852 #define new_XNV()       (void*)new_xnv()
 853 #define del_XNV(p)      del_xnv((XPVNV*) p)
 854
 855 #define new_XRV()       (void*)new_xrv()
 856 #define del_XRV(p)      del_xrv((XRV*) p)
 857
 858 #define new_XPV()       (void*)new_xpv()
 859 #define del_XPV(p)      del_xpv((XPV *)p)
 860
 861 #define new_XPVIV()     (void*)new_xpviv()
 862 #define del_XPVIV(p)    del_xpviv((XPVIV *)p)
 863
 864 #define new_XPVNV()     (void*)new_xpvnv()
 865 #define del_XPVNV(p)    del_xpvnv((XPVNV *)p)
 866
 867 #define new_XPVCV()     (void*)new_xpvcv()
 868 #define del_XPVCV(p)    del_xpvcv((XPVCV *)p)
 869
 870 #define new_XPVAV()     (void*)new_xpvav()
 871 #define del_XPVAV(p)    del_xpvav((XPVAV *)p)
 872
 873 #define new_XPVHV()     (void*)new_xpvhv()
 874 #define del_XPVHV(p)    del_xpvhv((XPVHV *)p)
 875
 876 #define new_XPVMG()     (void*)new_xpvmg()
 877 #define del_XPVMG(p)    del_xpvmg((XPVMG *)p)
 878
 879 #define new_XPVLV()     (void*)new_xpvlv()
 880 #define del_XPVLV(p)    del_xpvlv((XPVLV *)p)
 881
 882 #define new_XPVBM()     (void*)new_xpvbm()
 883 #define del_XPVBM(p)    del_xpvbm((XPVBM *)p)
 884
 885 #endif /* PURIFY */
 886
 887 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
 888 #define del_XPVGV(p)    my_safefree(p)
 889
 890 #define new_XPVFM()     my_safemalloc(sizeof(XPVFM))
 891 #define del_XPVFM(p)    my_safefree(p)
 892
 893 #define new_XPVIO()     my_safemalloc(sizeof(XPVIO))
 894 #define del_XPVIO(p)    my_safefree(p)
 895
 896 /*
 897 =for apidoc sv_upgrade
 898
 899 Upgrade an SV to a more complex form.  Use C<SvUPGRADE>.  See
 900 C<svtype>.
 901
 902 =cut
 903 */
 904
 905 bool
 906 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
 907 {
 908     char*       pv;
 909     U32         cur;
 910     U32         len;
 911     IV          iv;
 912     NV          nv;
 913     MAGIC*      magic;
 914     HV*         stash;
 915
 916     if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
 917         sv_force_normal(sv);
 918     }
 919
 920     if (SvTYPE(sv) == mt)
 921         return TRUE;
 922
 923     if (mt < SVt_PVIV)
 924         (void)SvOOK_off(sv);
 925
 926     switch (SvTYPE(sv)) {
 927     case SVt_NULL:
 928         pv      = 0;
 929         cur     = 0;
 930         len     = 0;
 931         iv      = 0;
 932         nv      = 0.0;
 933         magic   = 0;
 934         stash   = 0;
 935         break;
 936     case SVt_IV:
 937         pv      = 0;
 938         cur     = 0;
 939         len     = 0;
 940         iv      = SvIVX(sv);
 941         nv      = (NV)SvIVX(sv);
 942         del_XIV(SvANY(sv));
 943         magic   = 0;
 944         stash   = 0;
 945         if (mt == SVt_NV)
 946             mt = SVt_PVNV;
 947         else if (mt < SVt_PVIV)
 948             mt = SVt_PVIV;
 949         break;
 950     case SVt_NV:
 951         pv      = 0;
 952         cur     = 0;
 953         len     = 0;
 954         nv      = SvNVX(sv);
 955         iv      = I_V(nv);
 956         magic   = 0;
 957         stash   = 0;
 958         del_XNV(SvANY(sv));
 959         SvANY(sv) = 0;
 960         if (mt < SVt_PVNV)
 961             mt = SVt_PVNV;
 962         break;
 963     case SVt_RV:
 964         pv      = (char*)SvRV(sv);
 965         cur     = 0;
 966         len     = 0;
 967         iv      = PTR2IV(pv);
 968         nv      = PTR2NV(pv);
 969         del_XRV(SvANY(sv));
 970         magic   = 0;
 971         stash   = 0;
 972         break;
 973     case SVt_PV:
 974         pv      = SvPVX(sv);
 975         cur     = SvCUR(sv);
 976         len     = SvLEN(sv);
 977         iv      = 0;
 978         nv      = 0.0;
 979         magic   = 0;
 980         stash   = 0;
 981         del_XPV(SvANY(sv));
 982         if (mt <= SVt_IV)
 983             mt = SVt_PVIV;
 984         else if (mt == SVt_NV)
 985             mt = SVt_PVNV;
 986         break;
 987     case SVt_PVIV:
 988         pv      = SvPVX(sv);
 989         cur     = SvCUR(sv);
 990         len     = SvLEN(sv);
 991         iv      = SvIVX(sv);
 992         nv      = 0.0;
 993         magic   = 0;
 994         stash   = 0;
 995         del_XPVIV(SvANY(sv));
 996         break;
 997     case SVt_PVNV:
 998         pv      = SvPVX(sv);
 999         cur     = SvCUR(sv);
1000         len     = SvLEN(sv);
1001         iv      = SvIVX(sv);
1002         nv      = SvNVX(sv);
1003         magic   = 0;
1004         stash   = 0;
1005         del_XPVNV(SvANY(sv));
1006         break;
1007     case SVt_PVMG:
1008         pv      = SvPVX(sv);
1009         cur     = SvCUR(sv);
1010         len     = SvLEN(sv);
1011         iv      = SvIVX(sv);
1012         nv      = SvNVX(sv);
1013         magic   = SvMAGIC(sv);
1014         stash   = SvSTASH(sv);
1015         del_XPVMG(SvANY(sv));
1016         break;
1017     default:
1018         Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1019     }
1020
1021     switch (mt) {
1022     case SVt_NULL:
1023         Perl_croak(aTHX_ "Can't upgrade to undef");
1024     case SVt_IV:
1025         SvANY(sv) = new_XIV();
1026         SvIVX(sv)       = iv;
1027         break;
1028     case SVt_NV:
1029         SvANY(sv) = new_XNV();
1030         SvNVX(sv)       = nv;
1031         break;
1032     case SVt_RV:
1033         SvANY(sv) = new_XRV();
1034         SvRV(sv) = (SV*)pv;
1035         break;
1036     case SVt_PV:
1037         SvANY(sv) = new_XPV();
1038         SvPVX(sv)       = pv;
1039         SvCUR(sv)       = cur;
1040         SvLEN(sv)       = len;
1041         break;
1042     case SVt_PVIV:
1043         SvANY(sv) = new_XPVIV();
1044         SvPVX(sv)       = pv;
1045         SvCUR(sv)       = cur;
1046         SvLEN(sv)       = len;
1047         SvIVX(sv)       = iv;
1048         if (SvNIOK(sv))
1049             (void)SvIOK_on(sv);
1050         SvNOK_off(sv);
1051         break;
1052     case SVt_PVNV:
1053         SvANY(sv) = new_XPVNV();
1054         SvPVX(sv)       = pv;
1055         SvCUR(sv)       = cur;
1056         SvLEN(sv)       = len;
1057         SvIVX(sv)       = iv;
1058         SvNVX(sv)       = nv;
1059         break;
1060     case SVt_PVMG:
1061         SvANY(sv) = new_XPVMG();
1062         SvPVX(sv)       = pv;
1063         SvCUR(sv)       = cur;
1064         SvLEN(sv)       = len;
1065         SvIVX(sv)       = iv;
1066         SvNVX(sv)       = nv;
1067         SvMAGIC(sv)     = magic;
1068         SvSTASH(sv)     = stash;
1069         break;
1070     case SVt_PVLV:
1071         SvANY(sv) = new_XPVLV();
1072         SvPVX(sv)       = pv;
1073         SvCUR(sv)       = cur;
1074         SvLEN(sv)       = len;
1075         SvIVX(sv)       = iv;
1076         SvNVX(sv)       = nv;
1077         SvMAGIC(sv)     = magic;
1078         SvSTASH(sv)     = stash;
1079         LvTARGOFF(sv)   = 0;
1080         LvTARGLEN(sv)   = 0;
1081         LvTARG(sv)      = 0;
1082         LvTYPE(sv)      = 0;
1083         break;
1084     case SVt_PVAV:
1085         SvANY(sv) = new_XPVAV();
1086         if (pv)
1087             Safefree(pv);
1088         SvPVX(sv)       = 0;
1089         AvMAX(sv)       = -1;
1090         AvFILLp(sv)     = -1;
1091         SvIVX(sv)       = 0;
1092         SvNVX(sv)       = 0.0;
1093         SvMAGIC(sv)     = magic;
1094         SvSTASH(sv)     = stash;
1095         AvALLOC(sv)     = 0;
1096         AvARYLEN(sv)    = 0;
1097         AvFLAGS(sv)     = 0;
1098         break;
1099     case SVt_PVHV:
1100         SvANY(sv) = new_XPVHV();
1101         if (pv)
1102             Safefree(pv);
1103         SvPVX(sv)       = 0;
1104         HvFILL(sv)      = 0;
1105         HvMAX(sv)       = 0;
1106         HvKEYS(sv)      = 0;
1107         SvNVX(sv)       = 0.0;
1108         SvMAGIC(sv)     = magic;
1109         SvSTASH(sv)     = stash;
1110         HvRITER(sv)     = 0;
1111         HvEITER(sv)     = 0;
1112         HvPMROOT(sv)    = 0;
1113         HvNAME(sv)      = 0;
1114         break;
1115     case SVt_PVCV:
1116         SvANY(sv) = new_XPVCV();
1117         Zero(SvANY(sv), 1, XPVCV);
1118         SvPVX(sv)       = pv;
1119         SvCUR(sv)       = cur;
1120         SvLEN(sv)       = len;
1121         SvIVX(sv)       = iv;
1122         SvNVX(sv)       = nv;
1123         SvMAGIC(sv)     = magic;
1124         SvSTASH(sv)     = stash;
1125         break;
1126     case SVt_PVGV:
1127         SvANY(sv) = new_XPVGV();
1128         SvPVX(sv)       = pv;
1129         SvCUR(sv)       = cur;
1130         SvLEN(sv)       = len;
1131         SvIVX(sv)       = iv;
1132         SvNVX(sv)       = nv;
1133         SvMAGIC(sv)     = magic;
1134         SvSTASH(sv)     = stash;
1135         GvGP(sv)        = 0;
1136         GvNAME(sv)      = 0;
1137         GvNAMELEN(sv)   = 0;
1138         GvSTASH(sv)     = 0;
1139         GvFLAGS(sv)     = 0;
1140         break;
1141     case SVt_PVBM:
1142         SvANY(sv) = new_XPVBM();
1143         SvPVX(sv)       = pv;
1144         SvCUR(sv)       = cur;
1145         SvLEN(sv)       = len;
1146         SvIVX(sv)       = iv;
1147         SvNVX(sv)       = nv;
1148         SvMAGIC(sv)     = magic;
1149         SvSTASH(sv)     = stash;
1150         BmRARE(sv)      = 0;
1151         BmUSEFUL(sv)    = 0;
1152         BmPREVIOUS(sv)  = 0;
1153         break;
1154     case SVt_PVFM:
1155         SvANY(sv) = new_XPVFM();
1156         Zero(SvANY(sv), 1, XPVFM);
1157         SvPVX(sv)       = pv;
1158         SvCUR(sv)       = cur;
1159         SvLEN(sv)       = len;
1160         SvIVX(sv)       = iv;
1161         SvNVX(sv)       = nv;
1162         SvMAGIC(sv)     = magic;
1163         SvSTASH(sv)     = stash;
1164         break;
1165     case SVt_PVIO:
1166         SvANY(sv) = new_XPVIO();
1167         Zero(SvANY(sv), 1, XPVIO);
1168         SvPVX(sv)       = pv;
1169         SvCUR(sv)       = cur;
1170         SvLEN(sv)       = len;
1171         SvIVX(sv)       = iv;
1172         SvNVX(sv)       = nv;
1173         SvMAGIC(sv)     = magic;
1174         SvSTASH(sv)     = stash;
1175         IoPAGE_LEN(sv)  = 60;
1176         break;
1177     }
1178     SvFLAGS(sv) &= ~SVTYPEMASK;
1179     SvFLAGS(sv) |= mt;
1180     return TRUE;
1181 }
1182
1183 int
1184 Perl_sv_backoff(pTHX_ register SV *sv)
1185 {
1186     assert(SvOOK(sv));
1187     if (SvIVX(sv)) {
1188         char *s = SvPVX(sv);
1189         SvLEN(sv) += SvIVX(sv);
1190         SvPVX(sv) -= SvIVX(sv);
1191         SvIV_set(sv, 0);
1192         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1193     }
1194     SvFLAGS(sv) &= ~SVf_OOK;
1195     return 0;
1196 }
1197
1198 /*
1199 =for apidoc sv_grow
1200
1201 Expands the character buffer in the SV.  This will use C<sv_unref> and will
1202 upgrade the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1203 Use C<SvGROW>.
1204
1205 =cut
1206 */
1207
1208 char *
1209 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1210 {
1211     register char *s;
1212
1213 #ifdef HAS_64K_LIMIT
1214     if (newlen >= 0x10000) {
1215         PerlIO_printf(Perl_debug_log,
1216                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1217         my_exit(1);
1218     }
1219 #endif /* HAS_64K_LIMIT */
1220     if (SvROK(sv))
1221         sv_unref(sv);
1222     if (SvTYPE(sv) < SVt_PV) {
1223         sv_upgrade(sv, SVt_PV);
1224         s = SvPVX(sv);
1225     }
1226     else if (SvOOK(sv)) {       /* pv is offset? */
1227         sv_backoff(sv);
1228         s = SvPVX(sv);
1229         if (newlen > SvLEN(sv))
1230             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1231 #ifdef HAS_64K_LIMIT
1232         if (newlen >= 0x10000)
1233             newlen = 0xFFFF;
1234 #endif
1235     }
1236     else
1237         s = SvPVX(sv);
1238     if (newlen > SvLEN(sv)) {           /* need more room? */
1239         if (SvLEN(sv) && s) {
1240 #if defined(MYMALLOC) && !defined(LEAKTEST)
1241             STRLEN l = malloced_size((void*)SvPVX(sv));
1242             if (newlen <= l) {
1243                 SvLEN_set(sv, l);
1244                 return s;
1245             } else
1246 #endif
1247             Renew(s,newlen,char);
1248         }
1249         else
1250             New(703,s,newlen,char);
1251         SvPV_set(sv, s);
1252         SvLEN_set(sv, newlen);
1253     }
1254     return s;
1255 }
1256
1257 /*
1258 =for apidoc sv_setiv
1259
1260 Copies an integer into the given SV.  Does not handle 'set' magic.  See
1261 C<sv_setiv_mg>.
1262
1263 =cut
1264 */
1265
1266 void
1267 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1268 {
1269     SV_CHECK_THINKFIRST(sv);
1270     switch (SvTYPE(sv)) {
1271     case SVt_NULL:
1272         sv_upgrade(sv, SVt_IV);
1273         break;
1274     case SVt_NV:
1275         sv_upgrade(sv, SVt_PVNV);
1276         break;
1277     case SVt_RV:
1278     case SVt_PV:
1279         sv_upgrade(sv, SVt_PVIV);
1280         break;
1281
1282     case SVt_PVGV:
1283     case SVt_PVAV:
1284     case SVt_PVHV:
1285     case SVt_PVCV:
1286     case SVt_PVFM:
1287     case SVt_PVIO:
1288         Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1289                    PL_op_desc[PL_op->op_type]);
1290     }
1291     (void)SvIOK_only(sv);                       /* validate number */
1292     SvIVX(sv) = i;
1293     SvTAINT(sv);
1294 }
1295
1296 /*
1297 =for apidoc sv_setiv_mg
1298
1299 Like C<sv_setiv>, but also handles 'set' magic.
1300
1301 =cut
1302 */
1303
1304 void
1305 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1306 {
1307     sv_setiv(sv,i);
1308     SvSETMAGIC(sv);
1309 }
1310
1311 /*
1312 =for apidoc sv_setuv
1313
1314 Copies an unsigned integer into the given SV.  Does not handle 'set' magic.
1315 See C<sv_setuv_mg>.
1316
1317 =cut
1318 */
1319
1320 void
1321 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1322 {
1323     /* With these two if statements:
1324        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1325
1326        without
1327        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1328
1329        If you wish to remove them, please benchmark to see what the effect is
1330     */
1331     if (u <= (UV)IV_MAX) {
1332        sv_setiv(sv, (IV)u);
1333        return;
1334     }
1335     sv_setiv(sv, 0);
1336     SvIsUV_on(sv);
1337     SvUVX(sv) = u;
1338 }
1339
1340 /*
1341 =for apidoc sv_setuv_mg
1342
1343 Like C<sv_setuv>, but also handles 'set' magic.
1344
1345 =cut
1346 */
1347
1348 void
1349 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1350 {
1351     /* With these two if statements:
1352        u=1.49  s=0.52  cu=72.49  cs=10.64  scripts=270  tests=20865
1353
1354        without
1355        u=1.35  s=0.47  cu=73.45  cs=11.43  scripts=270  tests=20865
1356
1357        If you wish to remove them, please benchmark to see what the effect is
1358     */
1359     if (u <= (UV)IV_MAX) {
1360        sv_setiv(sv, (IV)u);
1361     } else {
1362        sv_setiv(sv, 0);
1363        SvIsUV_on(sv);
1364        sv_setuv(sv,u);
1365     }
1366     SvSETMAGIC(sv);
1367 }
1368
1369 /*
1370 =for apidoc sv_setnv
1371
1372 Copies a double into the given SV.  Does not handle 'set' magic.  See
1373 C<sv_setnv_mg>.
1374
1375 =cut
1376 */
1377
1378 void
1379 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1380 {
1381     SV_CHECK_THINKFIRST(sv);
1382     switch (SvTYPE(sv)) {
1383     case SVt_NULL:
1384     case SVt_IV:
1385         sv_upgrade(sv, SVt_NV);
1386         break;
1387     case SVt_RV:
1388     case SVt_PV:
1389     case SVt_PVIV:
1390         sv_upgrade(sv, SVt_PVNV);
1391         break;
1392
1393     case SVt_PVGV:
1394     case SVt_PVAV:
1395     case SVt_PVHV:
1396     case SVt_PVCV:
1397     case SVt_PVFM:
1398     case SVt_PVIO:
1399         Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1400                    PL_op_name[PL_op->op_type]);
1401     }
1402     SvNVX(sv) = num;
1403     (void)SvNOK_only(sv);                       /* validate number */
1404     SvTAINT(sv);
1405 }
1406
1407 /*
1408 =for apidoc sv_setnv_mg
1409
1410 Like C<sv_setnv>, but also handles 'set' magic.
1411
1412 =cut
1413 */
1414
1415 void
1416 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1417 {
1418     sv_setnv(sv,num);
1419     SvSETMAGIC(sv);
1420 }
1421
1422 STATIC void
1423 S_not_a_number(pTHX_ SV *sv)
1424 {
1425     char tmpbuf[64];
1426     char *d = tmpbuf;
1427     char *s;
1428     char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1429                   /* each *s can expand to 4 chars + "...\0",
1430                      i.e. need room for 8 chars */
1431
1432     for (s = SvPVX(sv); *s && d < limit; s++) {
1433         int ch = *s & 0xFF;
1434         if (ch & 128 && !isPRINT_LC(ch)) {
1435             *d++ = 'M';
1436             *d++ = '-';
1437             ch &= 127;
1438         }
1439         if (ch == '\n') {
1440             *d++ = '\\';
1441             *d++ = 'n';
1442         }
1443         else if (ch == '\r') {
1444             *d++ = '\\';
1445             *d++ = 'r';
1446         }
1447         else if (ch == '\f') {
1448             *d++ = '\\';
1449             *d++ = 'f';
1450         }
1451         else if (ch == '\\') {
1452             *d++ = '\\';
1453             *d++ = '\\';
1454         }
1455         else if (isPRINT_LC(ch))
1456             *d++ = ch;
1457         else {
1458             *d++ = '^';
1459             *d++ = toCTRL(ch);
1460         }
1461     }
1462     if (*s) {
1463         *d++ = '.';
1464         *d++ = '.';
1465         *d++ = '.';
1466     }
1467     *d = '\0';
1468
1469     if (PL_op)
1470         Perl_warner(aTHX_ WARN_NUMERIC,
1471                     "Argument \"%s\" isn't numeric in %s", tmpbuf,
1472                 PL_op_desc[PL_op->op_type]);
1473     else
1474         Perl_warner(aTHX_ WARN_NUMERIC,
1475                     "Argument \"%s\" isn't numeric", tmpbuf);
1476 }
1477
1478 /* the number can be converted to integer with atol() or atoll() although */
1479 #define IS_NUMBER_TO_INT_BY_ATOL     0x01 /* integer (may have decimals) */
1480 #define IS_NUMBER_TO_INT_BY_STRTOL   0x02 /* it may exceed IV_MAX */
1481 #define IS_NUMBER_TO_INT_BY_ATOF     0x04 /* seen something like 123e4 */
1482 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1483 #define IS_NUMBER_AS_LONG_AS_IV_MAX  0x10 /* may(be not) larger than IV_MAX */
1484 #define IS_NUMBER_NOT_INT            0x20 /* seen a decimal point or e */
1485 #define IS_NUMBER_NEG                0x40 /* seen a leading - */
1486 #define IS_NUMBER_INFINITY           0x80 /* /^\s*-?Infinity\s*$/i */
1487
1488 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1489    until proven guilty, assume that things are not that bad... */
1490
1491 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1492    an IV (an assumption perl has been based on to date) it becomes necessary
1493    to remove the assumption that the NV always carries enough precision to
1494    recreate the IV whenever needed, and that the NV is the canonical form.
1495    Instead, IV/UV and NV need to be given equal rights. So as to not lose
1496    precision as an side effect of conversion (which would lead to insanity
1497    and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1498    1) to distinguish between IV/UV/NV slots that have cached a valid
1499       conversion where precision was lost and IV/UV/NV slots that have a
1500       valid conversion which has lost no precision
1501    2) to ensure that if a numeric conversion to one form is request that
1502       would lose precision, the precise conversion (or differently
1503       imprecise conversion) is also performed and cached, to prevent
1504       requests for different numeric formats on the same SV causing
1505       lossy conversion chains. (lossless conversion chains are perfectly
1506       acceptable (still))
1507
1508
1509    flags are used:
1510    SvIOKp is true if the IV slot contains a valid value
1511    SvIOK  is true only if the IV value is accurate (UV if SvIOK_UV true)
1512    SvNOKp is true if the NV slot contains a valid value
1513    SvNOK  is true only if the NV value is accurate
1514
1515    so
1516    while converting from PV to NV check to see if converting that NV to an
1517    IV(or UV) would lose accuracy over a direct conversion from PV to
1518    IV(or UV). If it would, cache both conversions, return NV, but mark
1519    SV as IOK NOKp (ie not NOK).
1520
1521    while converting from PV to IV check to see if converting that IV to an
1522    NV would lose accuracy over a direct conversion from PV to NV. If it
1523    would, cache both conversions, flag similarly.
1524
1525    Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1526    correctly because if IV & NV were set NV *always* overruled.
1527    Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1528    changes - now IV and NV together means that the two are interchangeable
1529    SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1530
1531    The benefit of this is operations such as pp_add know that if SvIOK is
1532    true for both left and right operands, then integer addition can be
1533    used instead of floating point. (for cases where the result won't
1534    overflow) Before, floating point was always used, which could lead to
1535    loss of precision compared with integer addition.
1536
1537    * making IV and NV equal status should make maths accurate on 64 bit
1538      platforms
1539    * may speed up maths somewhat if pp_add and friends start to use
1540      integers when possible instead of fp. (hopefully the overhead in
1541      looking for SvIOK and checking for overflow will not outweigh the
1542      fp to integer speedup)
1543    * will slow down integer operations (callers of SvIV) on "inaccurate"
1544      values, as the change from SvIOK to SvIOKp will cause a call into
1545      sv_2iv each time rather than a macro access direct to the IV slot
1546    * should speed up number->string conversion on integers as IV is
1547      favoured when IV and NV equally accurate
1548
1549    ####################################################################
1550    You had better be using SvIOK_notUV if you want an IV for arithmetic
1551    SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1552    SvUOK is true iff UV.
1553    ####################################################################
1554
1555    Your mileage will vary depending your CPUs relative fp to integer
1556    performance ratio.
1557 */
1558
1559 #ifndef NV_PRESERVES_UV
1560 #define IS_NUMBER_UNDERFLOW_IV 1
1561 #define IS_NUMBER_UNDERFLOW_UV 2
1562 #define IS_NUMBER_IV_AND_UV 2
1563 #define IS_NUMBER_OVERFLOW_IV 4
1564 #define IS_NUMBER_OVERFLOW_UV 5
1565 /* Hopefully your optimiser will consider inlining these two functions.  */
1566 STATIC int
1567 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1568     NV nv = SvNVX(sv);          /* Code simpler and had compiler problems if */
1569     UV nv_as_uv = U_V(nv);      /*  these are not in simple variables.   */
1570     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVxf"\n", SvPVX(sv), SvIVX(sv), nv, (UV)numtype));
1571     if (nv_as_uv <= (UV)IV_MAX) {
1572         (void)SvIOKp_on(sv);
1573         (void)SvNOKp_on(sv);
1574         /* Within suitable range to fit in an IV,  atol won't overflow */
1575         /* XXX quite sure? Is that your final answer? not really, I'm
1576            trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1577         SvIVX(sv) = (IV)Atol(SvPVX(sv));
1578         if (numtype & IS_NUMBER_NOT_INT) {
1579             /* I believe that even if the original PV had decimals, they
1580                are lost beyond the limit of the FP precision.
1581                However, neither is canonical, so both only get p flags.
1582                NWC, 2000/11/25 */
1583             /* Both already have p flags, so do nothing */
1584         } else if (SvIVX(sv) == I_V(nv)) {
1585             SvNOK_on(sv);
1586             SvIOK_on(sv);
1587         } else {
1588             SvIOK_on(sv);
1589             /* It had no "." so it must be integer.  assert (get in here from
1590                sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1591                IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1592                conversion routines need audit.  */
1593         }
1594         return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1595     }
1596     /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1597     (void)SvIOKp_on(sv);
1598     (void)SvNOKp_on(sv);
1599 #ifdef HAS_STRTOUL
1600     {
1601         int save_errno = errno;
1602         errno = 0;
1603         SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1604         if (errno == 0) {
1605             if (numtype & IS_NUMBER_NOT_INT) {
1606                 /* UV and NV both imprecise.  */
1607                 SvIsUV_on(sv);
1608             } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1609                 SvNOK_on(sv);
1610                 SvIOK_on(sv);
1611                 SvIsUV_on(sv);
1612             } else {
1613                 SvIOK_on(sv);
1614                 SvIsUV_on(sv);
1615             }
1616             errno = save_errno;
1617             return IS_NUMBER_OVERFLOW_IV;
1618         }
1619         errno = save_errno;
1620         SvNOK_on(sv);
1621         /* Must have just overflowed UV, but not enough that an NV could spot
1622            this.. */
1623         return IS_NUMBER_OVERFLOW_UV;
1624     }
1625 #else
1626     /* We've just lost integer precision, nothing we could do. */
1627     SvUVX(sv) = nv_as_uv;
1628     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%"UVxf"\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, (UV)numtype));
1629     /* UV and NV slots equally valid only if we have casting symmetry. */
1630     if (numtype & IS_NUMBER_NOT_INT) {
1631         SvIsUV_on(sv);
1632     } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1633         /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1634            UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1635            get to this point if NVs don't preserve UVs) */
1636         SvNOK_on(sv);
1637         SvIOK_on(sv);
1638         SvIsUV_on(sv);
1639     } else {
1640         /* As above, I believe UV at least as good as NV */
1641         SvIsUV_on(sv);
1642     }
1643 #endif /* HAS_STRTOUL */
1644     return IS_NUMBER_OVERFLOW_IV;
1645 }
1646
1647 /* For sv_2nv these three cases are "SvNOK and don't bother casting"  */
1648 STATIC int
1649 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1650 {
1651     DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVxf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1652     if (SvNVX(sv) < (NV)IV_MIN) {
1653         (void)SvIOKp_on(sv);
1654         (void)SvNOK_on(sv);
1655         SvIVX(sv) = IV_MIN;
1656         return IS_NUMBER_UNDERFLOW_IV;
1657     }
1658     if (SvNVX(sv) > (NV)UV_MAX) {
1659         (void)SvIOKp_on(sv);
1660         (void)SvNOK_on(sv);
1661         SvIsUV_on(sv);
1662         SvUVX(sv) = UV_MAX;
1663         return IS_NUMBER_OVERFLOW_UV;
1664     }
1665     if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1666         (void)SvIOKp_on(sv);
1667         (void)SvNOK_on(sv);
1668         /* Can't use strtol etc to convert this string */
1669         if (SvNVX(sv) <= (UV)IV_MAX) {
1670             SvIVX(sv) = I_V(SvNVX(sv));
1671             if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1672                 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1673             } else {
1674                 /* Integer is imprecise. NOK, IOKp */
1675             }
1676             return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1677         }
1678         SvIsUV_on(sv);
1679         SvUVX(sv) = U_V(SvNVX(sv));
1680         if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1681             if (SvUVX(sv) == UV_MAX) {
1682                 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1683                    possibly be preserved by NV. Hence, it must be overflow.
1684                    NOK, IOKp */
1685                 return IS_NUMBER_OVERFLOW_UV;
1686             }
1687             SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1688         } else {
1689             /* Integer is imprecise. NOK, IOKp */
1690         }
1691         return IS_NUMBER_OVERFLOW_IV;
1692     }
1693     return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
1694 }
1695 #endif /* NV_PRESERVES_UV*/
1696
1697 IV
1698 Perl_sv_2iv(pTHX_ register SV *sv)
1699 {
1700     if (!sv)
1701         return 0;
1702     if (SvGMAGICAL(sv)) {
1703         mg_get(sv);
1704         if (SvIOKp(sv))
1705             return SvIVX(sv);
1706         if (SvNOKp(sv)) {
1707             return I_V(SvNVX(sv));
1708         }
1709         if (SvPOKp(sv) && SvLEN(sv))
1710             return asIV(sv);
1711         if (!SvROK(sv)) {
1712             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1713                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1714                     report_uninit();
1715             }
1716             return 0;
1717         }
1718     }
1719     if (SvTHINKFIRST(sv)) {
1720         if (SvROK(sv)) {
1721           SV* tmpstr;
1722           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1723                   (SvRV(tmpstr) != SvRV(sv)))
1724               return SvIV(tmpstr);
1725           return PTR2IV(SvRV(sv));
1726         }
1727         if (SvREADONLY(sv) && SvFAKE(sv)) {
1728             sv_force_normal(sv);
1729         }
1730         if (SvREADONLY(sv) && !SvOK(sv)) {
1731             if (ckWARN(WARN_UNINITIALIZED))
1732                 report_uninit();
1733             return 0;
1734         }
1735     }
1736     if (SvIOKp(sv)) {
1737         if (SvIsUV(sv)) {
1738             return (IV)(SvUVX(sv));
1739         }
1740         else {
1741             return SvIVX(sv);
1742         }
1743     }
1744     if (SvNOKp(sv)) {
1745         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1746          * without also getting a cached IV/UV from it at the same time
1747          * (ie PV->NV conversion should detect loss of accuracy and cache
1748          * IV or UV at same time to avoid this.  NWC */
1749
1750         if (SvTYPE(sv) == SVt_NV)
1751             sv_upgrade(sv, SVt_PVNV);
1752
1753         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
1754         /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1755            certainly cast into the IV range at IV_MAX, whereas the correct
1756            answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1757            cases go to UV */
1758         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1759             SvIVX(sv) = I_V(SvNVX(sv));
1760             if (SvNVX(sv) == (NV) SvIVX(sv)
1761 #ifndef NV_PRESERVES_UV
1762                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1763                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1764                 /* Don't flag it as "accurately an integer" if the number
1765                    came from a (by definition imprecise) NV operation, and
1766                    we're outside the range of NV integer precision */
1767 #endif
1768                 ) {
1769                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
1770                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1771                                       "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1772                                       PTR2UV(sv),
1773                                       SvNVX(sv),
1774                                       SvIVX(sv)));
1775
1776             } else {
1777                 /* IV not precise.  No need to convert from PV, as NV
1778                    conversion would already have cached IV if it detected
1779                    that PV->IV would be better than PV->NV->IV
1780                    flags already correct - don't set public IOK.  */
1781                 DEBUG_c(PerlIO_printf(Perl_debug_log,
1782                                       "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1783                                       PTR2UV(sv),
1784                                       SvNVX(sv),
1785                                       SvIVX(sv)));
1786             }
1787             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1788                but the cast (NV)IV_MIN rounds to a the value less (more
1789                negative) than IV_MIN which happens to be equal to SvNVX ??
1790                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1791                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1792                (NV)UVX == NVX are both true, but the values differ. :-(
1793                Hopefully for 2s complement IV_MIN is something like
1794                0x8000000000000000 which will be exact. NWC */
1795         }
1796         else {
1797             SvUVX(sv) = U_V(SvNVX(sv));
1798             if (
1799                 (SvNVX(sv) == (NV) SvUVX(sv))
1800 #ifndef  NV_PRESERVES_UV
1801                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1802                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1803                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1804                 /* Don't flag it as "accurately an integer" if the number
1805                    came from a (by definition imprecise) NV operation, and
1806                    we're outside the range of NV integer precision */
1807 #endif
1808                 )
1809                 SvIOK_on(sv);
1810             SvIsUV_on(sv);
1811           ret_iv_max:
1812             DEBUG_c(PerlIO_printf(Perl_debug_log,
1813                                   "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1814                                   PTR2UV(sv),
1815                                   SvUVX(sv),
1816                                   SvUVX(sv)));
1817             return (IV)SvUVX(sv);
1818         }
1819     }
1820     else if (SvPOKp(sv) && SvLEN(sv)) {
1821         I32 numtype = looks_like_number(sv);
1822
1823         /* We want to avoid a possible problem when we cache an IV which
1824            may be later translated to an NV, and the resulting NV is not
1825            the translation of the initial data.
1826
1827            This means that if we cache such an IV, we need to cache the
1828            NV as well.  Moreover, we trade speed for space, and do not
1829            cache the NV if we are sure it's not needed.
1830          */
1831
1832         if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1833             /* The NV may be reconstructed from IV - safe to cache IV,
1834                 which may be calculated by atol(). */
1835             if (SvTYPE(sv) < SVt_PVIV)
1836                 sv_upgrade(sv, SVt_PVIV);
1837             (void)SvIOK_on(sv);
1838             SvIVX(sv) = Atol(SvPVX(sv));
1839         } else {
1840 #ifdef HAS_STRTOL
1841             IV i;
1842             int save_errno = errno;
1843             /* Is it an integer that we could convert with strtol?
1844                So try it, and if it doesn't set errno then it's pukka.
1845                This should be faster than going atof and then thinking.  */
1846             if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1847                   == IS_NUMBER_TO_INT_BY_STRTOL)
1848                 /* && is a sequence point. Without it not sure if I'm trying
1849                    to do too much between sequence points and hence going
1850                    undefined */
1851                 && ((errno = 0), 1) /* , 1 so always true */
1852                 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1853                 && (errno == 0)) {
1854                 if (SvTYPE(sv) < SVt_PVIV)
1855                     sv_upgrade(sv, SVt_PVIV);
1856                 (void)SvIOK_on(sv);
1857                 SvIVX(sv) = i;
1858                 errno = save_errno;
1859             } else
1860 #endif
1861             {
1862                 NV d;
1863 #ifdef HAS_STRTOL
1864                 /* Hopefully trace flow will optimise this away where possible
1865                  */
1866                 errno = save_errno;
1867 #endif
1868                 /* It wasn't an integer, or it overflowed, or we don't have
1869                    strtol. Do things the slow way - check if it's a UV etc. */
1870                 d = Atof(SvPVX(sv));
1871
1872                 if (SvTYPE(sv) < SVt_PVNV)
1873                     sv_upgrade(sv, SVt_PVNV);
1874                 SvNVX(sv) = d;
1875
1876                 if (! numtype && ckWARN(WARN_NUMERIC))
1877                     not_a_number(sv);
1878
1879 #if defined(USE_LONG_DOUBLE)
1880                 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1881                                       PTR2UV(sv), SvNVX(sv)));
1882 #else
1883                 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1884                                       PTR2UV(sv), SvNVX(sv)));
1885 #endif
1886
1887
1888 #ifdef NV_PRESERVES_UV
1889                 (void)SvIOKp_on(sv);
1890                 (void)SvNOK_on(sv);
1891                 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1892                     SvIVX(sv) = I_V(SvNVX(sv));
1893                     if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1894                         SvIOK_on(sv);
1895                     } else {
1896                         /* Integer is imprecise. NOK, IOKp */
1897                     }
1898                     /* UV will not work better than IV */
1899                 } else {
1900                     if (SvNVX(sv) > (NV)UV_MAX) {
1901                         SvIsUV_on(sv);
1902                         /* Integer is inaccurate. NOK, IOKp, is UV */
1903                         SvUVX(sv) = UV_MAX;
1904                         SvIsUV_on(sv);
1905                     } else {
1906                         SvUVX(sv) = U_V(SvNVX(sv));
1907                         /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1908                         if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1909                             SvIOK_on(sv);
1910                             SvIsUV_on(sv);
1911                         } else {
1912                             /* Integer is imprecise. NOK, IOKp, is UV */
1913                             SvIsUV_on(sv);
1914                         }
1915                     }
1916                     goto ret_iv_max;
1917                 }
1918 #else /* NV_PRESERVES_UV */
1919                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1920                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1921                     /* Small enough to preserve all bits. */
1922                     (void)SvIOKp_on(sv);
1923                     SvNOK_on(sv);
1924                     SvIVX(sv) = I_V(SvNVX(sv));
1925                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
1926                         SvIOK_on(sv);
1927                     /* Assumption: first non-preserved integer is < IV_MAX,
1928                        this NV is in the preserved range, therefore: */
1929                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1930                           < (UV)IV_MAX)) {
1931                         Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
1932                     }
1933                 } else if (sv_2iuv_non_preserve (sv, numtype)
1934                            >= IS_NUMBER_OVERFLOW_IV)
1935                     goto ret_iv_max;
1936 #endif /* NV_PRESERVES_UV */
1937             }
1938         }
1939     } else  {
1940         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1941             report_uninit();
1942         if (SvTYPE(sv) < SVt_IV)
1943             /* Typically the caller expects that sv_any is not NULL now.  */
1944             sv_upgrade(sv, SVt_IV);
1945         return 0;
1946     }
1947     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1948         PTR2UV(sv),SvIVX(sv)));
1949     return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1950 }
1951
1952 UV
1953 Perl_sv_2uv(pTHX_ register SV *sv)
1954 {
1955     if (!sv)
1956         return 0;
1957     if (SvGMAGICAL(sv)) {
1958         mg_get(sv);
1959         if (SvIOKp(sv))
1960             return SvUVX(sv);
1961         if (SvNOKp(sv))
1962             return U_V(SvNVX(sv));
1963         if (SvPOKp(sv) && SvLEN(sv))
1964             return asUV(sv);
1965         if (!SvROK(sv)) {
1966             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1967                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1968                     report_uninit();
1969             }
1970             return 0;
1971         }
1972     }
1973     if (SvTHINKFIRST(sv)) {
1974         if (SvROK(sv)) {
1975           SV* tmpstr;
1976           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1977                   (SvRV(tmpstr) != SvRV(sv)))
1978               return SvUV(tmpstr);
1979           return PTR2UV(SvRV(sv));
1980         }
1981         if (SvREADONLY(sv) && SvFAKE(sv)) {
1982             sv_force_normal(sv);
1983         }
1984         if (SvREADONLY(sv) && !SvOK(sv)) {
1985             if (ckWARN(WARN_UNINITIALIZED))
1986                 report_uninit();
1987             return 0;
1988         }
1989     }
1990     if (SvIOKp(sv)) {
1991         if (SvIsUV(sv)) {
1992             return SvUVX(sv);
1993         }
1994         else {
1995             return (UV)SvIVX(sv);
1996         }
1997     }
1998     if (SvNOKp(sv)) {
1999         /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2000          * without also getting a cached IV/UV from it at the same time
2001          * (ie PV->NV conversion should detect loss of accuracy and cache
2002          * IV or UV at same time to avoid this. */
2003         /* IV-over-UV optimisation - choose to cache IV if possible */
2004
2005         if (SvTYPE(sv) == SVt_NV)
2006             sv_upgrade(sv, SVt_PVNV);
2007
2008         (void)SvIOKp_on(sv);    /* Must do this first, to clear any SvOOK */
2009         if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2010             SvIVX(sv) = I_V(SvNVX(sv));
2011             if (SvNVX(sv) == (NV) SvIVX(sv)
2012 #ifndef NV_PRESERVES_UV
2013                 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2014                     (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2015                 /* Don't flag it as "accurately an integer" if the number
2016                    came from a (by definition imprecise) NV operation, and
2017                    we're outside the range of NV integer precision */
2018 #endif
2019                 ) {
2020                 SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
2021                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2022                                       "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2023                                       PTR2UV(sv),
2024                                       SvNVX(sv),
2025                                       SvIVX(sv)));
2026
2027             } else {
2028                 /* IV not precise.  No need to convert from PV, as NV
2029                    conversion would already have cached IV if it detected
2030                    that PV->IV would be better than PV->NV->IV
2031                    flags already correct - don't set public IOK.  */
2032                 DEBUG_c(PerlIO_printf(Perl_debug_log,
2033                                       "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2034                                       PTR2UV(sv),
2035                                       SvNVX(sv),
2036                                       SvIVX(sv)));
2037             }
2038             /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2039                but the cast (NV)IV_MIN rounds to a the value less (more
2040                negative) than IV_MIN which happens to be equal to SvNVX ??
2041                Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2042                NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2043                (NV)UVX == NVX are both true, but the values differ. :-(
2044                Hopefully for 2s complement IV_MIN is something like
2045                0x8000000000000000 which will be exact. NWC */
2046         }
2047         else {
2048             SvUVX(sv) = U_V(SvNVX(sv));
2049             if (
2050                 (SvNVX(sv) == (NV) SvUVX(sv))
2051 #ifndef  NV_PRESERVES_UV
2052                 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2053                 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2054                 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2055                 /* Don't flag it as "accurately an integer" if the number
2056                    came from a (by definition imprecise) NV operation, and
2057                    we're outside the range of NV integer precision */
2058 #endif
2059                 )
2060                 SvIOK_on(sv);
2061             SvIsUV_on(sv);
2062             DEBUG_c(PerlIO_printf(Perl_debug_log,
2063                                   "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2064                                   PTR2UV(sv),
2065                                   SvUVX(sv),
2066                                   SvUVX(sv)));
2067         }
2068     }
2069     else if (SvPOKp(sv) && SvLEN(sv)) {
2070         I32 numtype = looks_like_number(sv);
2071
2072         /* We want to avoid a possible problem when we cache a UV which
2073            may be later translated to an NV, and the resulting NV is not
2074            the translation of the initial data.
2075
2076            This means that if we cache such a UV, we need to cache the
2077            NV as well.  Moreover, we trade speed for space, and do not
2078            cache the NV if not needed.
2079          */
2080
2081         if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2082             /* The NV may be reconstructed from IV - safe to cache IV,
2083                 which may be calculated by atol(). */
2084             if (SvTYPE(sv) < SVt_PVIV)
2085                 sv_upgrade(sv, SVt_PVIV);
2086             (void)SvIOK_on(sv);
2087             SvIVX(sv) = Atol(SvPVX(sv));
2088         } else {
2089 #ifdef HAS_STRTOUL
2090             UV u;
2091             char *num_begin = SvPVX(sv);
2092             int save_errno = errno;
2093
2094             /* seems that strtoul taking numbers that start with - is
2095                implementation dependant, and can't be relied upon.  */
2096             if (numtype & IS_NUMBER_NEG) {
2097                 /* Not totally defensive. assumine that looks_like_num
2098                    didn't lie about a - sign */
2099                 while (isSPACE(*num_begin))
2100                     num_begin++;
2101                 if (*num_begin == '-')
2102                     num_begin++;
2103             }
2104
2105             /* Is it an integer that we could convert with strtoul?
2106                So try it, and if it doesn't set errno then it's pukka.
2107                This should be faster than going atof and then thinking.  */
2108             if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2109                  == IS_NUMBER_TO_INT_BY_STRTOL)
2110                 && ((errno = 0), 1) /* always true */
2111                 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2112                 && (errno == 0)
2113                 /* If known to be negative, check it didn't undeflow IV
2114                    XXX possibly we should put more negative values as NVs
2115                    direct rather than go via atof below */
2116                 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2117                 errno = save_errno;
2118
2119                 if (SvTYPE(sv) < SVt_PVIV)
2120                     sv_upgrade(sv, SVt_PVIV);
2121                 (void)SvIOK_on(sv);
2122
2123                 /* If it's negative must use IV.
2124                    IV-over-UV optimisation */
2125                 if (numtype & IS_NUMBER_NEG) {
2126                     SvIVX(sv) = -(IV)u;
2127                 } else if (u <= (UV) IV_MAX) {
2128                     SvIVX(sv) = (IV)u;
2129                 } else {
2130                     /* it didn't overflow, and it was positive. */
2131                     SvUVX(sv) = u;
2132                     SvIsUV_on(sv);
2133                 }
2134             } else
2135 #endif
2136             {
2137                 NV d;
2138 #ifdef HAS_STRTOUL
2139                 /* Hopefully trace flow will optimise this away where possible
2140                  */
2141                 errno = save_errno;
2142 #endif
2143                 /* It wasn't an integer, or it overflowed, or we don't have
2144                    strtol. Do things the slow way - check if it's a IV etc. */
2145                 d = Atof(SvPVX(sv));
2146
2147                 if (SvTYPE(sv) < SVt_PVNV)
2148                     sv_upgrade(sv, SVt_PVNV);
2149                 SvNVX(sv) = d;
2150
2151                 if (! numtype && ckWARN(WARN_NUMERIC))
2152                     not_a_number(sv);
2153
2154 #if defined(USE_LONG_DOUBLE)
2155                 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2156                                       PTR2UV(sv), SvNVX(sv)));
2157 #else
2158                 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2159                                       PTR2UV(sv), SvNVX(sv)));
2160 #endif
2161
2162 #ifdef NV_PRESERVES_UV
2163                 (void)SvIOKp_on(sv);
2164                 (void)SvNOK_on(sv);
2165                 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2166                     SvIVX(sv) = I_V(SvNVX(sv));
2167                     if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2168                         SvIOK_on(sv);
2169                     } else {
2170                         /* Integer is imprecise. NOK, IOKp */
2171                     }
2172                     /* UV will not work better than IV */
2173                 } else {
2174                     if (SvNVX(sv) > (NV)UV_MAX) {
2175                         SvIsUV_on(sv);
2176                         /* Integer is inaccurate. NOK, IOKp, is UV */
2177                         SvUVX(sv) = UV_MAX;
2178                         SvIsUV_on(sv);
2179                     } else {
2180                         SvUVX(sv) = U_V(SvNVX(sv));
2181                         /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2182                            NV preservse UV so can do correct comparison.  */
2183                         if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2184                             SvIOK_on(sv);
2185                             SvIsUV_on(sv);
2186                         } else {
2187                             /* Integer is imprecise. NOK, IOKp, is UV */
2188                             SvIsUV_on(sv);
2189                         }
2190                     }
2191                 }
2192 #else /* NV_PRESERVES_UV */
2193                 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2194                     U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2195                     /* Small enough to preserve all bits. */
2196                     (void)SvIOKp_on(sv);
2197                     SvNOK_on(sv);
2198                     SvIVX(sv) = I_V(SvNVX(sv));
2199                     if ((NV)(SvIVX(sv)) == SvNVX(sv))
2200                         SvIOK_on(sv);
2201                     /* Assumption: first non-preserved integer is < IV_MAX,
2202                        this NV is in the preserved range, therefore: */
2203                     if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2204                           < (UV)IV_MAX)) {
2205                         Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2206                     }
2207                 } else
2208                     sv_2iuv_non_preserve (sv, numtype);
2209 #endif /* NV_PRESERVES_UV */
2210             }
2211         }
2212     }
2213     else  {
2214         if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2215             if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2216                 report_uninit();
2217         }
2218         if (SvTYPE(sv) < SVt_IV)
2219             /* Typically the caller expects that sv_any is not NULL now.  */
2220             sv_upgrade(sv, SVt_IV);
2221         return 0;
2222     }
2223
2224     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2225                           PTR2UV(sv),SvUVX(sv)));
2226     return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2227 }
2228
2229 NV
2230 Perl_sv_2nv(pTHX_ register SV *sv)
2231 {
2232     if (!sv)
2233         return 0.0;
2234     if (SvGMAGICAL(sv)) {
2235         mg_get(sv);
2236         if (SvNOKp(sv))
2237             return SvNVX(sv);
2238         if (SvPOKp(sv) && SvLEN(sv)) {
2239             if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2240                 not_a_number(sv);
2241             return Atof(SvPVX(sv));
2242         }
2243         if (SvIOKp(sv)) {
2244             if (SvIsUV(sv))
2245                 return (NV)SvUVX(sv);
2246             else
2247                 return (NV)SvIVX(sv);
2248         }
2249         if (!SvROK(sv)) {
2250             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2251                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2252                     report_uninit();
2253             }
2254             return 0;
2255         }
2256     }
2257     if (SvTHINKFIRST(sv)) {
2258         if (SvROK(sv)) {
2259           SV* tmpstr;
2260           if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2261                   (SvRV(tmpstr) != SvRV(sv)))
2262               return SvNV(tmpstr);
2263           return PTR2NV(SvRV(sv));
2264         }
2265         if (SvREADONLY(sv) && SvFAKE(sv)) {
2266             sv_force_normal(sv);
2267         }
2268         if (SvREADONLY(sv) && !SvOK(sv)) {
2269             if (ckWARN(WARN_UNINITIALIZED))
2270                 report_uninit();
2271             return 0.0;
2272         }
2273     }
2274     if (SvTYPE(sv) < SVt_NV) {
2275         if (SvTYPE(sv) == SVt_IV)
2276             sv_upgrade(sv, SVt_PVNV);
2277         else
2278             sv_upgrade(sv, SVt_NV);
2279 #if defined(USE_LONG_DOUBLE)
2280         DEBUG_c({
2281             STORE_NUMERIC_LOCAL_SET_STANDARD();
2282             PerlIO_printf(Perl_debug_log,
2283                           "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2284                           PTR2UV(sv), SvNVX(sv));
2285             RESTORE_NUMERIC_LOCAL();
2286         });
2287 #else
2288         DEBUG_c({
2289             STORE_NUMERIC_LOCAL_SET_STANDARD();
2290             PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2291                           PTR2UV(sv), SvNVX(sv));
2292             RESTORE_NUMERIC_LOCAL();
2293         });
2294 #endif
2295     }
2296     else if (SvTYPE(sv) < SVt_PVNV)
2297         sv_upgrade(sv, SVt_PVNV);
2298     if (SvIOKp(sv) &&
2299             (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2300     {
2301         SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2302 #ifdef NV_PRESERVES_UV
2303         SvNOK_on(sv);
2304 #else
2305         /* Only set the public NV OK flag if this NV preserves the IV  */
2306         /* Check it's not 0xFFFFFFFFFFFFFFFF */
2307         if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2308                        : (SvIVX(sv) == I_V(SvNVX(sv))))
2309             SvNOK_on(sv);
2310         else
2311             SvNOKp_on(sv);
2312 #endif
2313     }
2314     else if (SvPOKp(sv) && SvLEN(sv)) {
2315         if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2316             not_a_number(sv);
2317         SvNVX(sv) = Atof(SvPVX(sv));
2318 #ifdef NV_PRESERVES_UV
2319         SvNOK_on(sv);
2320 #else
2321         /* Only set the public NV OK flag if this NV preserves the value in
2322            the PV at least as well as an IV/UV would.
2323            Not sure how to do this 100% reliably. */
2324         /* if that shift count is out of range then Configure's test is
2325            wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2326            UV_BITS */
2327         if (((UV)1 << NV_PRESERVES_UV_BITS) >
2328             U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2329             SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2330         else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2331                 /* Definitely too large/small to fit in an integer, so no loss
2332                    of precision going to integer in the future via NV */
2333             SvNOK_on(sv);
2334         } else {
2335             /* Is it something we can run through strtol etc (ie no
2336                trailing exponent part)? */
2337             int numtype = looks_like_number(sv);
2338             /* XXX probably should cache this if called above */
2339
2340             if (!(numtype &
2341                   (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2342                 /* Can't use strtol etc to convert this string, so don't try */
2343                 SvNOK_on(sv);
2344             } else
2345                 sv_2inuv_non_preserve (sv, numtype);
2346         }
2347 #endif /* NV_PRESERVES_UV */
2348     }
2349     else  {
2350         if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2351             report_uninit();
2352         if (SvTYPE(sv) < SVt_NV)
2353             /* Typically the caller expects that sv_any is not NULL now.  */
2354             /* XXX Ilya implies that this is a bug in callers that assume this
2355                and ideally should be fixed.  */
2356             sv_upgrade(sv, SVt_NV);
2357         return 0.0;
2358     }
2359 #if defined(USE_LONG_DOUBLE)
2360     DEBUG_c({
2361         STORE_NUMERIC_LOCAL_SET_STANDARD();
2362         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2363                       PTR2UV(sv), SvNVX(sv));
2364         RESTORE_NUMERIC_LOCAL();
2365     });
2366 #else
2367     DEBUG_c({
2368         STORE_NUMERIC_LOCAL_SET_STANDARD();
2369         PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2370                       PTR2UV(sv), SvNVX(sv));
2371         RESTORE_NUMERIC_LOCAL();
2372     });
2373 #endif
2374     return SvNVX(sv);
2375 }
2376
2377 STATIC IV
2378 S_asIV(pTHX_ SV *sv)
2379 {
2380     I32 numtype = looks_like_number(sv);
2381     NV d;
2382
2383     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2384         return Atol(SvPVX(sv));
2385     if (!numtype) {
2386         if (ckWARN(WARN_NUMERIC))
2387             not_a_number(sv);
2388     }
2389     d = Atof(SvPVX(sv));
2390     return I_V(d);
2391 }
2392
2393 STATIC UV
2394 S_asUV(pTHX_ SV *sv)
2395 {
2396     I32 numtype = looks_like_number(sv);
2397
2398 #ifdef HAS_STRTOUL
2399     if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2400         return Strtoul(SvPVX(sv), Null(char**), 10);
2401 #endif
2402     if (!numtype) {
2403         if (ckWARN(WARN_NUMERIC))
2404             not_a_number(sv);
2405     }
2406     return U_V(Atof(SvPVX(sv)));
2407 }
2408
2409 /*
2410  * Returns a combination of (advisory only - can get false negatives)
2411  * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2412  * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2413  * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2414  * 0 if does not look like number.
2415  *
2416  * (atol and strtol stop when they hit a decimal point. strtol will return
2417  * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2418  * do this, and vendors have had 11 years to get it right.
2419  * However, will try to make it still work with only atol
2420  *
2421  * IS_NUMBER_TO_INT_BY_ATOL     123456789 or 123456789.3  definitely < IV_MAX
2422  * IS_NUMBER_TO_INT_BY_STRTOL   123456789 or 123456789.3  if digits = IV_MAX
2423  * IS_NUMBER_TO_INT_BY_ATOF     123456789e0               or >> IV_MAX
2424  * IS_NUMBER_LONGER_THAN_IV_MAX   lots of digits, don't bother with atol
2425  * IS_NUMBER_AS_LONG_AS_IV_MAX    atol might hit LONG_MAX, might not.
2426  * IS_NUMBER_NOT_INT            saw "." or "e"
2427  * IS_NUMBER_NEG
2428  * IS_NUMBER_INFINITY
2429  */
2430
2431 /*
2432 =for apidoc looks_like_number
2433
2434 Test if an the content of an SV looks like a number (or is a
2435 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2436 issue a non-numeric warning), even if your atof() doesn't grok them.
2437
2438 =cut
2439 */
2440
2441 I32
2442 Perl_looks_like_number(pTHX_ SV *sv)
2443 {
2444     register char *s;
2445     register char *send;
2446     register char *sbegin;
2447     register char *nbegin;
2448     I32 numtype = 0;
2449     I32 sawinf  = 0;
2450     STRLEN len;
2451
2452     if (SvPOK(sv)) {
2453         sbegin = SvPVX(sv);
2454         len = SvCUR(sv);
2455     }
2456     else if (SvPOKp(sv))
2457         sbegin = SvPV(sv, len);
2458     else
2459         return 1;
2460     send = sbegin + len;
2461
2462     s = sbegin;
2463     while (isSPACE(*s))
2464         s++;
2465     if (*s == '-') {
2466         s++;
2467         numtype = IS_NUMBER_NEG;
2468     }
2469     else if (*s == '+')
2470         s++;
2471
2472     nbegin = s;
2473     /*
2474      * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2475      * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2476      * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2477      * will need (int)atof().
2478      */
2479
2480     /* next must be digit or the radix separator or beginning of infinity */
2481     if (isDIGIT(*s)) {
2482         do {
2483             s++;
2484         } while (isDIGIT(*s));
2485
2486         /* Aaargh. long long really is irritating.
2487            In the gospel according to ANSI 1989, it is an axiom that "long"
2488            is the longest integer type, and that if you don't know how long
2489            something is you can cast it to long, and nothing will be lost
2490            (except possibly speed of execution if long is slower than the
2491            type is was).
2492            Now, one can't be sure if the old rules apply, or long long
2493            (or some other newfangled thing) is actually longer than the
2494            (formerly) longest thing.
2495         */
2496         /* This lot will work for 64 bit  *as long as* either
2497            either long is 64 bit
2498            or     we can find both strtol/strtoq and strtoul/strtouq
2499            If not, we really should refuse to let the user use 64 bit IVs
2500            By "64 bit" I really mean IVs that don't get preserved by NVs
2501            It also should work for 128 bit IVs. Can any lend me a machine to
2502            test this?
2503         */
2504         if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2505             numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2506         else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2507                                           ? sizeof(long) : sizeof (IV))*8-1))
2508             numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2509         else
2510             /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2511                digit less (IV_MAX=  9223372036854775807,
2512                            UV_MAX= 18446744073709551615) so be cautious  */
2513             numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2514
2515         if (*s == '.'
2516 #ifdef USE_LOCALE_NUMERIC
2517             || IS_NUMERIC_RADIX(*s)
2518 #endif
2519             ) {
2520             s++;
2521             numtype |= IS_NUMBER_NOT_INT;
2522             while (isDIGIT(*s))  /* optional digits after the radix */
2523                 s++;
2524         }
2525     }
2526     else if (*s == '.'
2527 #ifdef USE_LOCALE_NUMERIC
2528             || IS_NUMERIC_RADIX(*s)
2529 #endif
2530             ) {
2531         s++;
2532         numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2533         /* no digits before the radix means we need digits after it */
2534         if (isDIGIT(*s)) {
2535             do {
2536                 s++;
2537             } while (isDIGIT(*s));
2538         }
2539         else
2540             return 0;
2541     }
2542     else if (*s == 'I' || *s == 'i') {
2543         s++; if (*s != 'N' && *s != 'n') return 0;
2544         s++; if (*s != 'F' && *s != 'f') return 0;
2545         s++; if (*s == 'I' || *s == 'i') {
2546             s++; if (*s != 'N' && *s != 'n') return 0;
2547             s++; if (*s != 'I' && *s != 'i') return 0;
2548             s++; if (*s != 'T' && *s != 't') return 0;
2549             s++; if (*s != 'Y' && *s != 'y') return 0;
2550             s++;
2551         }
2552         sawinf = 1;
2553     }
2554     else
2555         return 0;
2556
2557     if (sawinf)
2558         numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign  */
2559           | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2560     else {
2561         /* we can have an optional exponent part */
2562         if (*s == 'e' || *s == 'E') {
2563             numtype &= IS_NUMBER_NEG;
2564             numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2565             s++;
2566             if (*s == '+' || *s == '-')
2567                 s++;
2568             if (isDIGIT(*s)) {
2569                 do {
2570                     s++;
2571                 } while (isDIGIT(*s));
2572             }
2573             else
2574                 return 0;
2575         }
2576     }
2577     while (isSPACE(*s))
2578         s++;
2579     if (s >= send)
2580         return numtype;
2581     if (len == 10 && memEQ(sbegin, "0 but true", 10))
2582         return IS_NUMBER_TO_INT_BY_ATOL;
2583     return 0;
2584 }
2585
2586 char *
2587 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2588 {
2589     STRLEN n_a;
2590     return sv_2pv(sv, &n_a);
2591 }
2592
2593 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2594 static char *
2595 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2596 {
2597     char *ptr = buf + TYPE_CHARS(UV);
2598     char *ebuf = ptr;
2599     int sign;
2600
2601     if (is_uv)
2602         sign = 0;
2603     else if (iv >= 0) {
2604         uv = iv;
2605         sign = 0;
2606     } else {
2607         uv = -iv;
2608         sign = 1;
2609     }
2610     do {
2611         *--ptr = '0' + (uv % 10);
2612     } while (uv /= 10);
2613     if (sign)
2614         *--ptr = '-';
2615     *peob = ebuf;
2616     return ptr;
2617 }
2618
2619 char *
2620 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2621 {
2622     register char *s;
2623     int olderrno;
2624     SV *tsv;
2625     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2626     char *tmpbuf = tbuf;
2627
2628     if (!sv) {
2629         *lp = 0;
2630         return "";
2631     }
2632     if (SvGMAGICAL(sv)) {
2633         mg_get(sv);
2634         if (SvPOKp(sv)) {
2635             *lp = SvCUR(sv);
2636             return SvPVX(sv);
2637         }
2638         if (SvIOKp(sv)) {
2639             if (SvIsUV(sv))
2640                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2641             else
2642                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2643             tsv = Nullsv;
2644             goto tokensave;
2645         }
2646         if (SvNOKp(sv)) {
2647             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2648             tsv = Nullsv;
2649             goto tokensave;
2650         }
2651         if (!SvROK(sv)) {
2652             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2653                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2654                     report_uninit();
2655             }
2656             *lp = 0;
2657             return "";
2658         }
2659     }
2660     if (SvTHINKFIRST(sv)) {
2661         if (SvROK(sv)) {
2662             SV* tmpstr;
2663             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2664                     (SvRV(tmpstr) != SvRV(sv)))
2665                 return SvPV(tmpstr,*lp);
2666             sv = (SV*)SvRV(sv);
2667             if (!sv)
2668                 s = "NULLREF";
2669             else {
2670                 MAGIC *mg;
2671
2672                 switch (SvTYPE(sv)) {
2673                 case SVt_PVMG:
2674                     if ( ((SvFLAGS(sv) &
2675                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2676                           == (SVs_OBJECT|SVs_RMG))
2677                          && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2678                          && (mg = mg_find(sv, 'r'))) {
2679                         regexp *re = (regexp *)mg->mg_obj;
2680
2681                         if (!mg->mg_ptr) {
2682                             char *fptr = "msix";
2683                             char reflags[6];
2684                             char ch;
2685                             int left = 0;
2686                             int right = 4;
2687                             U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2688
2689                             while((ch = *fptr++)) {
2690                                 if(reganch & 1) {
2691                                     reflags[left++] = ch;
2692                                 }
2693                                 else {
2694                                     reflags[right--] = ch;
2695                                 }
2696                                 reganch >>= 1;
2697                             }
2698                             if(left != 4) {
2699                                 reflags[left] = '-';
2700                                 left = 5;
2701                             }
2702
2703                             mg->mg_len = re->prelen + 4 + left;
2704                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2705                             Copy("(?", mg->mg_ptr, 2, char);
2706                             Copy(reflags, mg->mg_ptr+2, left, char);
2707                             Copy(":", mg->mg_ptr+left+2, 1, char);
2708                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2709                             mg->mg_ptr[mg->mg_len - 1] = ')';
2710                             mg->mg_ptr[mg->mg_len] = 0;
2711                         }
2712                         PL_reginterp_cnt += re->program[0].next_off;
2713                         *lp = mg->mg_len;
2714                         return mg->mg_ptr;
2715                     }
2716                                         /* Fall through */
2717                 case SVt_NULL:
2718                 case SVt_IV:
2719                 case SVt_NV:
2720                 case SVt_RV:
2721                 case SVt_PV:
2722                 case SVt_PVIV:
2723                 case SVt_PVNV:
2724                 case SVt_PVBM:  if (SvROK(sv))
2725                                     s = "REF";
2726                                 else
2727                                     s = "SCALAR";               break;
2728                 case SVt_PVLV:  s = "LVALUE";                   break;
2729                 case SVt_PVAV:  s = "ARRAY";                    break;
2730                 case SVt_PVHV:  s = "HASH";                     break;
2731                 case SVt_PVCV:  s = "CODE";                     break;
2732                 case SVt_PVGV:  s = "GLOB";                     break;
2733                 case SVt_PVFM:  s = "FORMAT";                   break;
2734                 case SVt_PVIO:  s = "IO";                       break;
2735                 default:        s = "UNKNOWN";                  break;
2736                 }
2737                 tsv = NEWSV(0,0);
2738                 if (SvOBJECT(sv))
2739                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2740                 else
2741                     sv_setpv(tsv, s);
2742                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2743                 goto tokensaveref;
2744             }
2745             *lp = strlen(s);
2746             return s;
2747         }
2748         if (SvREADONLY(sv) && !SvOK(sv)) {
2749             if (ckWARN(WARN_UNINITIALIZED))
2750                 report_uninit();
2751             *lp = 0;
2752             return "";
2753         }
2754     }
2755     if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2756         /* I'm assuming that if both IV and NV are equally valid then
2757            converting the IV is going to be more efficient */
2758         U32 isIOK = SvIOK(sv);
2759         U32 isUIOK = SvIsUV(sv);
2760         char buf[TYPE_CHARS(UV)];
2761         char *ebuf, *ptr;
2762
2763         if (SvTYPE(sv) < SVt_PVIV)
2764             sv_upgrade(sv, SVt_PVIV);
2765         if (isUIOK)
2766             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2767         else
2768             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2769         SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
2770         Move(ptr,SvPVX(sv),ebuf - ptr,char);
2771         SvCUR_set(sv, ebuf - ptr);
2772         s = SvEND(sv);
2773         *s = '\0';
2774         if (isIOK)
2775             SvIOK_on(sv);
2776         else
2777             SvIOKp_on(sv);
2778         if (isUIOK)
2779             SvIsUV_on(sv);
2780     }
2781     else if (SvNOKp(sv)) {
2782         if (SvTYPE(sv) < SVt_PVNV)
2783             sv_upgrade(sv, SVt_PVNV);
2784         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2785         SvGROW(sv, NV_DIG + 20);
2786         s = SvPVX(sv);
2787         olderrno = errno;       /* some Xenix systems wipe out errno here */
2788 #ifdef apollo
2789         if (SvNVX(sv) == 0.0)
2790             (void)strcpy(s,"0");
2791         else
2792 #endif /*apollo*/
2793         {
2794             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2795         }
2796         errno = olderrno;
2797 #ifdef FIXNEGATIVEZERO
2798         if (*s == '-' && s[1] == '0' && !s[2])
2799             strcpy(s,"0");
2800 #endif
2801         while (*s) s++;
2802 #ifdef hcx
2803         if (s[-1] == '.')
2804             *--s = '\0';
2805 #endif
2806     }
2807     else {
2808         if (ckWARN(WARN_UNINITIALIZED)
2809             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2810             report_uninit();
2811         *lp = 0;
2812         if (SvTYPE(sv) < SVt_PV)
2813             /* Typically the caller expects that sv_any is not NULL now.  */
2814             sv_upgrade(sv, SVt_PV);
2815         return "";
2816     }
2817     *lp = s - SvPVX(sv);
2818     SvCUR_set(sv, *lp);
2819     SvPOK_on(sv);
2820     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2821                           PTR2UV(sv),SvPVX(sv)));
2822     return SvPVX(sv);
2823
2824   tokensave:
2825     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
2826         /* Sneaky stuff here */
2827
2828       tokensaveref:
2829         if (!tsv)
2830             tsv = newSVpv(tmpbuf, 0);
2831         sv_2mortal(tsv);
2832         *lp = SvCUR(tsv);
2833         return SvPVX(tsv);
2834     }
2835     else {
2836         STRLEN len;
2837         char *t;
2838
2839         if (tsv) {
2840             sv_2mortal(tsv);
2841             t = SvPVX(tsv);
2842             len = SvCUR(tsv);
2843         }
2844         else {
2845             t = tmpbuf;
2846             len = strlen(tmpbuf);
2847         }
2848 #ifdef FIXNEGATIVEZERO
2849         if (len == 2 && t[0] == '-' && t[1] == '0') {
2850             t = "0";
2851             len = 1;
2852         }
2853 #endif
2854         (void)SvUPGRADE(sv, SVt_PV);
2855         *lp = len;
2856         s = SvGROW(sv, len + 1);
2857         SvCUR_set(sv, len);
2858         (void)strcpy(s, t);
2859         SvPOKp_on(sv);
2860         return s;
2861     }
2862 }
2863
2864 char *
2865 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2866 {
2867     STRLEN n_a;
2868     return sv_2pvbyte(sv, &n_a);
2869 }
2870
2871 char *
2872 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2873 {
2874     return sv_2pv(sv,lp);
2875 }
2876
2877 char *
2878 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2879 {
2880     STRLEN n_a;
2881     return sv_2pvutf8(sv, &n_a);
2882 }
2883
2884 char *
2885 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2886 {
2887     sv_utf8_upgrade(sv);
2888     return SvPV(sv,*lp);
2889 }
2890
2891 /* This function is only called on magical items */
2892 bool
2893 Perl_sv_2bool(pTHX_ register SV *sv)
2894 {
2895     if (SvGMAGICAL(sv))
2896         mg_get(sv);
2897
2898     if (!SvOK(sv))
2899         return 0;
2900     if (SvROK(sv)) {
2901         SV* tmpsv;
2902         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2903                 (SvRV(tmpsv) != SvRV(sv)))
2904             return SvTRUE(tmpsv);
2905       return SvRV(sv) != 0;
2906     }
2907     if (SvPOKp(sv)) {
2908         register XPV* Xpvtmp;
2909         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2910                 (*Xpvtmp->xpv_pv > '0' ||
2911                 Xpvtmp->xpv_cur > 1 ||
2912                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2913             return 1;
2914         else
2915             return 0;
2916     }
2917     else {
2918         if (SvIOKp(sv))
2919             return SvIVX(sv) != 0;
2920         else {
2921             if (SvNOKp(sv))
2922                 return SvNVX(sv) != 0.0;
2923             else
2924                 return FALSE;
2925         }
2926     }
2927 }
2928
2929 /*
2930 =for apidoc sv_utf8_upgrade
2931
2932 Convert the PV of an SV to its UTF8-encoded form.
2933
2934 =cut
2935 */
2936
2937 void
2938 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2939 {
2940     char *s, *t, *e;
2941     int  hibit = 0;
2942
2943     if (!sv || !SvPOK(sv) || SvUTF8(sv))
2944         return;
2945
2946     /* This function could be much more efficient if we had a FLAG in SVs
2947      * to signal if there are any hibit chars in the PV.
2948      * Given that there isn't make loop fast as possible
2949      */
2950     s = SvPVX(sv);
2951     e = SvEND(sv);
2952     t = s;
2953     while (t < e) {
2954         if ((hibit = UTF8_IS_CONTINUED(*t++)))
2955             break;
2956     }
2957
2958     if (hibit) {
2959         STRLEN len;
2960         if (SvREADONLY(sv) && SvFAKE(sv)) {
2961             sv_force_normal(sv);
2962             s = SvPVX(sv);
2963         }
2964         len = SvCUR(sv) + 1; /* Plus the \0 */
2965         SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2966         SvCUR(sv) = len - 1;
2967         if (SvLEN(sv) != 0)
2968             Safefree(s); /* No longer using what was there before. */
2969         SvLEN(sv) = len; /* No longer know the real size. */
2970         SvUTF8_on(sv);
2971     }
2972 }
2973
2974 /*
2975 =for apidoc sv_utf8_downgrade
2976
2977 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2978 This may not be possible if the PV contains non-byte encoding characters;
2979 if this is the case, either returns false or, if C<fail_ok> is not
2980 true, croaks.
2981
2982 =cut
2983 */
2984
2985 bool
2986 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2987 {
2988     if (SvPOK(sv) && SvUTF8(sv)) {
2989         if (SvCUR(sv)) {
2990             char *c = SvPVX(sv);
2991             STRLEN len = SvCUR(sv);
2992
2993             if (!utf8_to_bytes((U8*)c, &len)) {
2994                 if (fail_ok)
2995                     return FALSE;
2996                 else {
2997                     if (PL_op)
2998                         Perl_croak(aTHX_ "Wide character in %s",
2999                                    PL_op_desc[PL_op->op_type]);
3000                     else
3001                         Perl_croak(aTHX_ "Wide character");
3002                 }
3003             }
3004             SvCUR(sv) = len;
3005         }
3006         SvUTF8_off(sv);
3007     }
3008
3009     return TRUE;
3010 }
3011
3012 /*
3013 =for apidoc sv_utf8_encode
3014
3015 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3016 flag so that it looks like bytes again. Nothing calls this.
3017
3018 =cut
3019 */
3020
3021 void
3022 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3023 {
3024     sv_utf8_upgrade(sv);
3025     SvUTF8_off(sv);
3026 }
3027
3028 bool
3029 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3030 {
3031     if (SvPOK(sv)) {
3032         char *c;
3033         char *e;
3034         bool has_utf = FALSE;
3035         if (!sv_utf8_downgrade(sv, TRUE))
3036             return FALSE;
3037
3038         /* it is actually just a matter of turning the utf8 flag on, but
3039          * we want to make sure everything inside is valid utf8 first.
3040          */
3041         c = SvPVX(sv);
3042         if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
3043             return FALSE;
3044         e = SvEND(sv);
3045         while (c < e) {
3046             if (UTF8_IS_CONTINUED(*c++)) {
3047                 SvUTF8_on(sv);
3048                 break;
3049             }
3050         }
3051     }
3052     return TRUE;
3053 }
3054
3055
3056 /* Note: sv_setsv() should not be called with a source string that needs
3057  * to be reused, since it may destroy the source string if it is marked
3058  * as temporary.
3059  */
3060
3061 /*
3062 =for apidoc sv_setsv
3063
3064 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3065 The source SV may be destroyed if it is mortal.  Does not handle 'set'
3066 magic.  See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3067 C<sv_setsv_mg>.
3068
3069 =cut
3070 */
3071
3072 void
3073 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3074 {
3075     register U32 sflags;
3076     register int dtype;
3077     register int stype;
3078
3079     if (sstr == dstr)
3080         return;
3081     SV_CHECK_THINKFIRST(dstr);
3082     if (!sstr)
3083         sstr = &PL_sv_undef;
3084     stype = SvTYPE(sstr);
3085     dtype = SvTYPE(dstr);
3086
3087     SvAMAGIC_off(dstr);
3088
3089     /* There's a lot of redundancy below but we're going for speed here */
3090
3091     switch (stype) {
3092     case SVt_NULL:
3093       undef_sstr:
3094         if (dtype != SVt_PVGV) {
3095             (void)SvOK_off(dstr);
3096             return;
3097         }
3098         break;
3099     case SVt_IV:
3100         if (SvIOK(sstr)) {
3101             switch (dtype) {
3102             case SVt_NULL:
3103                 sv_upgrade(dstr, SVt_IV);
3104                 break;
3105             case SVt_NV:
3106                 sv_upgrade(dstr, SVt_PVNV);
3107                 break;
3108             case SVt_RV:
3109             case SVt_PV:
3110                 sv_upgrade(dstr, SVt_PVIV);
3111                 break;
3112             }
3113             (void)SvIOK_only(dstr);
3114             SvIVX(dstr) = SvIVX(sstr);
3115             if (SvIsUV(sstr))
3116                 SvIsUV_on(dstr);
3117             if (SvTAINTED(sstr))
3118                 SvTAINT(dstr);
3119             return;
3120         }
3121         goto undef_sstr;
3122
3123     case SVt_NV:
3124         if (SvNOK(sstr)) {
3125             switch (dtype) {
3126             case SVt_NULL:
3127             case SVt_IV:
3128                 sv_upgrade(dstr, SVt_NV);
3129                 break;
3130             case SVt_RV:
3131             case SVt_PV:
3132             case SVt_PVIV:
3133                 sv_upgrade(dstr, SVt_PVNV);
3134                 break;
3135             }
3136             SvNVX(dstr) = SvNVX(sstr);
3137             (void)SvNOK_only(dstr);
3138             if (SvTAINTED(sstr))
3139                 SvTAINT(dstr);
3140             return;
3141         }
3142         goto undef_sstr;
3143
3144     case SVt_RV:
3145         if (dtype < SVt_RV)
3146             sv_upgrade(dstr, SVt_RV);
3147         else if (dtype == SVt_PVGV &&
3148                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3149             sstr = SvRV(sstr);
3150             if (sstr == dstr) {
3151                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3152                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3153                 {
3154                     GvIMPORTED_on(dstr);
3155                 }
3156                 GvMULTI_on(dstr);
3157                 return;
3158             }
3159             goto glob_assign;
3160         }
3161         break;
3162     case SVt_PV:
3163     case SVt_PVFM:
3164         if (dtype < SVt_PV)
3165             sv_upgrade(dstr, SVt_PV);
3166         break;
3167     case SVt_PVIV:
3168         if (dtype < SVt_PVIV)
3169             sv_upgrade(dstr, SVt_PVIV);
3170         break;
3171     case SVt_PVNV:
3172         if (dtype < SVt_PVNV)
3173             sv_upgrade(dstr, SVt_PVNV);
3174         break;
3175     case SVt_PVAV:
3176     case SVt_PVHV:
3177     case SVt_PVCV:
3178     case SVt_PVIO:
3179         if (PL_op)
3180             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3181                 PL_op_name[PL_op->op_type]);
3182         else
3183             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3184         break;
3185
3186     case SVt_PVGV:
3187         if (dtype <= SVt_PVGV) {
3188   glob_assign:
3189             if (dtype != SVt_PVGV) {
3190                 char *name = GvNAME(sstr);
3191                 STRLEN len = GvNAMELEN(sstr);
3192                 sv_upgrade(dstr, SVt_PVGV);
3193                 sv_magic(dstr, dstr, '*', Nullch, 0);
3194                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3195                 GvNAME(dstr) = savepvn(name, len);
3196                 GvNAMELEN(dstr) = len;
3197                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3198             }
3199             /* ahem, death to those who redefine active sort subs */
3200             else if (PL_curstackinfo->si_type == PERLSI_SORT
3201                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3202                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3203                       GvNAME(dstr));
3204             (void)SvOK_off(dstr);
3205             GvINTRO_off(dstr);          /* one-shot flag */
3206             gp_free((GV*)dstr);
3207             GvGP(dstr) = gp_ref(GvGP(sstr));
3208             if (SvTAINTED(sstr))
3209                 SvTAINT(dstr);
3210             if (GvIMPORTED(dstr) != GVf_IMPORTED
3211                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3212             {
3213                 GvIMPORTED_on(dstr);
3214             }
3215             GvMULTI_on(dstr);
3216             return;
3217         }
3218         /* FALL THROUGH */
3219
3220     default:
3221         if (SvGMAGICAL(sstr)) {
3222             mg_get(sstr);
3223             if (SvTYPE(sstr) != stype) {
3224                 stype = SvTYPE(sstr);
3225                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3226                     goto glob_assign;
3227             }
3228         }
3229         if (stype == SVt_PVLV)
3230             (void)SvUPGRADE(dstr, SVt_PVNV);
3231         else
3232             (void)SvUPGRADE(dstr, stype);
3233     }
3234
3235     sflags = SvFLAGS(sstr);
3236
3237     if (sflags & SVf_ROK) {
3238         if (dtype >= SVt_PV) {
3239             if (dtype == SVt_PVGV) {
3240                 SV *sref = SvREFCNT_inc(SvRV(sstr));
3241                 SV *dref = 0;
3242                 int intro = GvINTRO(dstr);
3243
3244                 if (intro) {
3245                     GP *gp;
3246                     gp_free((GV*)dstr);
3247                     GvINTRO_off(dstr);  /* one-shot flag */
3248                     Newz(602,gp, 1, GP);
3249                     GvGP(dstr) = gp_ref(gp);
3250                     GvSV(dstr) = NEWSV(72,0);
3251                     GvLINE(dstr) = CopLINE(PL_curcop);
3252                     GvEGV(dstr) = (GV*)dstr;
3253                 }
3254                 GvMULTI_on(dstr);
3255                 switch (SvTYPE(sref)) {
3256                 case SVt_PVAV:
3257                     if (intro)
3258                         SAVESPTR(GvAV(dstr));
3259                     else
3260                         dref = (SV*)GvAV(dstr);
3261                     GvAV(dstr) = (AV*)sref;
3262                     if (!GvIMPORTED_AV(dstr)
3263                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3264                     {
3265                         GvIMPORTED_AV_on(dstr);
3266                     }
3267                     break;
3268                 case SVt_PVHV:
3269                     if (intro)
3270                         SAVESPTR(GvHV(dstr));
3271                     else
3272                         dref = (SV*)GvHV(dstr);
3273                     GvHV(dstr) = (HV*)sref;
3274                     if (!GvIMPORTED_HV(dstr)
3275                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3276                     {
3277                         GvIMPORTED_HV_on(dstr);
3278                     }
3279                     break;
3280                 case SVt_PVCV:
3281                     if (intro) {
3282                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3283                             SvREFCNT_dec(GvCV(dstr));
3284                             GvCV(dstr) = Nullcv;
3285                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3286                             PL_sub_generation++;
3287                         }
3288                         SAVESPTR(GvCV(dstr));
3289                     }
3290                     else
3291                         dref = (SV*)GvCV(dstr);
3292                     if (GvCV(dstr) != (CV*)sref) {
3293                         CV* cv = GvCV(dstr);
3294                         if (cv) {
3295                             if (!GvCVGEN((GV*)dstr) &&
3296                                 (CvROOT(cv) || CvXSUB(cv)))
3297                             {
3298                                 SV *const_sv;
3299                                 /* ahem, death to those who redefine
3300                                  * active sort subs */
3301                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3302                                       PL_sortcop == CvSTART(cv))
3303                                     Perl_croak(aTHX_
3304                                     "Can't redefine active sort subroutine %s",
3305                                           GvENAME((GV*)dstr));
3306                                 /* Redefining a sub - warning is mandatory if
3307                                    it was a const and its value changed. */
3308                                 if (ckWARN(WARN_REDEFINE)
3309                                     || (CvCONST(cv)
3310                                         && (!CvCONST((CV*)sref)
3311                                             || sv_cmp(cv_const_sv(cv),
3312                                                       cv_const_sv((CV*)sref)))))
3313                                 {
3314                                     Perl_warner(aTHX_ WARN_REDEFINE,
3315                                         CvCONST(cv)
3316                                         ? "Constant subroutine %s redefined"
3317                                         : "Subroutine %s redefined",
3318                                         GvENAME((GV*)dstr));
3319                                 }
3320                             }
3321                             cv_ckproto(cv, (GV*)dstr,
3322                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
3323                         }
3324                         GvCV(dstr) = (CV*)sref;
3325                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3326                         GvASSUMECV_on(dstr);
3327                         PL_sub_generation++;
3328                     }
3329                     if (!GvIMPORTED_CV(dstr)
3330                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3331                     {
3332                         GvIMPORTED_CV_on(dstr);
3333                     }
3334                     break;
3335                 case SVt_PVIO:
3336                     if (intro)
3337                         SAVESPTR(GvIOp(dstr));
3338                     else
3339                         dref = (SV*)GvIOp(dstr);
3340                     GvIOp(dstr) = (IO*)sref;
3341                     break;
3342                 case SVt_PVFM:
3343                     if (intro)
3344                         SAVESPTR(GvFORM(dstr));
3345                     else
3346                         dref = (SV*)GvFORM(dstr);
3347                     GvFORM(dstr) = (CV*)sref;
3348                     break;
3349                 default:
3350                     if (intro)
3351                         SAVESPTR(GvSV(dstr));
3352                     else
3353                         dref = (SV*)GvSV(dstr);
3354                     GvSV(dstr) = sref;
3355                     if (!GvIMPORTED_SV(dstr)
3356                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3357                     {
3358                         GvIMPORTED_SV_on(dstr);
3359                     }
3360                     break;
3361                 }
3362                 if (dref)
3363                     SvREFCNT_dec(dref);
3364                 if (intro)
3365                     SAVEFREESV(sref);
3366                 if (SvTAINTED(sstr))
3367                     SvTAINT(dstr);
3368                 return;
3369             }
3370             if (SvPVX(dstr)) {
3371                 (void)SvOOK_off(dstr);          /* backoff */
3372                 if (SvLEN(dstr))
3373                     Safefree(SvPVX(dstr));
3374                 SvLEN(dstr)=SvCUR(dstr)=0;
3375             }
3376         }
3377         (void)SvOK_off(dstr);
3378         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3379         SvROK_on(dstr);
3380         if (sflags & SVp_NOK) {
3381             SvNOKp_on(dstr);
3382             /* Only set the public OK flag if the source has public OK.  */
3383             if (sflags & SVf_NOK)
3384                 SvFLAGS(dstr) |= SVf_NOK;
3385             SvNVX(dstr) = SvNVX(sstr);
3386         }
3387         if (sflags & SVp_IOK) {
3388             (void)SvIOKp_on(dstr);
3389             if (sflags & SVf_IOK)
3390                 SvFLAGS(dstr) |= SVf_IOK;
3391             if (sflags & SVf_IVisUV)
3392                 SvIsUV_on(dstr);
3393             SvIVX(dstr) = SvIVX(sstr);
3394         }
3395         if (SvAMAGIC(sstr)) {
3396             SvAMAGIC_on(dstr);
3397         }
3398     }
3399     else if (sflags & SVp_POK) {
3400
3401         /*
3402          * Check to see if we can just swipe the string.  If so, it's a
3403          * possible small lose on short strings, but a big win on long ones.
3404          * It might even be a win on short strings if SvPVX(dstr)
3405          * has to be allocated and SvPVX(sstr) has to be freed.
3406          */
3407
3408         if (SvTEMP(sstr) &&             /* slated for free anyway? */
3409             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
3410             !(sflags & SVf_OOK) &&      /* and not involved in OOK hack? */
3411             SvLEN(sstr)         &&      /* and really is a string */
3412             !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3413         {
3414             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
3415                 if (SvOOK(dstr)) {
3416                     SvFLAGS(dstr) &= ~SVf_OOK;
3417                     Safefree(SvPVX(dstr) - SvIVX(dstr));
3418                 }
3419                 else if (SvLEN(dstr))
3420                     Safefree(SvPVX(dstr));
3421             }
3422             (void)SvPOK_only(dstr);
3423             SvPV_set(dstr, SvPVX(sstr));
3424             SvLEN_set(dstr, SvLEN(sstr));
3425             SvCUR_set(dstr, SvCUR(sstr));
3426
3427             SvTEMP_off(dstr);
3428             (void)SvOK_off(sstr);               /* NOTE: nukes most SvFLAGS on sstr */
3429             SvPV_set(sstr, Nullch);
3430             SvLEN_set(sstr, 0);
3431             SvCUR_set(sstr, 0);
3432             SvTEMP_off(sstr);
3433         }
3434         else {                                  /* have to copy actual string */
3435             STRLEN len = SvCUR(sstr);
3436
3437             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
3438             Move(SvPVX(sstr),SvPVX(dstr),len,char);
3439             SvCUR_set(dstr, len);
3440             *SvEND(dstr) = '\0';
3441             (void)SvPOK_only(dstr);
3442         }
3443         if ((sflags & SVf_UTF8) && !IN_BYTE)
3444             SvUTF8_on(dstr);
3445         /*SUPPRESS 560*/
3446         if (sflags & SVp_NOK) {
3447             SvNOKp_on(dstr);
3448             if (sflags & SVf_NOK)
3449                 SvFLAGS(dstr) |= SVf_NOK;
3450             SvNVX(dstr) = SvNVX(sstr);
3451         }
3452         if (sflags & SVp_IOK) {
3453             (void)SvIOKp_on(dstr);
3454             if (sflags & SVf_IOK)
3455                 SvFLAGS(dstr) |= SVf_IOK;
3456             if (sflags & SVf_IVisUV)
3457                 SvIsUV_on(dstr);
3458             SvIVX(dstr) = SvIVX(sstr);
3459         }
3460     }
3461     else if (sflags & SVp_IOK) {
3462         if (sflags & SVf_IOK)
3463             (void)SvIOK_only(dstr);
3464         else {
3465             SvOK_off(dstr);
3466             SvIOKp_on(dstr);
3467         }
3468         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3469         if (sflags & SVf_IVisUV)
3470             SvIsUV_on(dstr);
3471         SvIVX(dstr) = SvIVX(sstr);
3472         if (sflags & SVp_NOK) {
3473             if (sflags & SVf_NOK)
3474                 (void)SvNOK_on(dstr);
3475             else
3476                 (void)SvNOKp_on(dstr);
3477             SvNVX(dstr) = SvNVX(sstr);
3478         }
3479     }
3480     else if (sflags & SVp_NOK) {
3481         if (sflags & SVf_NOK)
3482             (void)SvNOK_only(dstr);
3483         else {
3484             SvOK_off(dstr);
3485             SvNOKp_on(dstr);
3486         }
3487         SvNVX(dstr) = SvNVX(sstr);
3488     }
3489     else {
3490         if (dtype == SVt_PVGV) {
3491             if (ckWARN(WARN_MISC))
3492                 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3493         }
3494         else
3495             (void)SvOK_off(dstr);
3496     }
3497     if (SvTAINTED(sstr))
3498         SvTAINT(dstr);
3499 }
3500
3501 /*
3502 =for apidoc sv_setsv_mg
3503
3504 Like C<sv_setsv>, but also handles 'set' magic.
3505
3506 =cut
3507 */
3508
3509 void
3510 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3511 {
3512     sv_setsv(dstr,sstr);
3513     SvSETMAGIC(dstr);
3514 }
3515
3516 /*
3517 =for apidoc sv_setpvn
3518
3519 Copies a string into an SV.  The C<len> parameter indicates the number of
3520 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
3521
3522 =cut
3523 */
3524
3525 void
3526 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3527 {
3528     register char *dptr;
3529     {
3530         /* len is STRLEN which is unsigned, need to copy to signed */
3531         IV iv = len;
3532         assert(iv >= 0);
3533     }
3534     SV_CHECK_THINKFIRST(sv);
3535     if (!ptr) {
3536         (void)SvOK_off(sv);
3537         return;
3538     }
3539     (void)SvUPGRADE(sv, SVt_PV);
3540
3541     SvGROW(sv, len + 1);
3542     dptr = SvPVX(sv);
3543     Move(ptr,dptr,len,char);
3544     dptr[len] = '\0';
3545     SvCUR_set(sv, len);
3546     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3547     SvTAINT(sv);
3548 }
3549
3550 /*
3551 =for apidoc sv_setpvn_mg
3552
3553 Like C<sv_setpvn>, but also handles 'set' magic.
3554
3555 =cut
3556 */
3557
3558 void
3559 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3560 {
3561     sv_setpvn(sv,ptr,len);
3562     SvSETMAGIC(sv);
3563 }
3564
3565 /*
3566 =for apidoc sv_setpv
3567
3568 Copies a string into an SV.  The string must be null-terminated.  Does not
3569 handle 'set' magic.  See C<sv_setpv_mg>.
3570
3571 =cut
3572 */
3573
3574 void
3575 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3576 {
3577     register STRLEN len;
3578
3579     SV_CHECK_THINKFIRST(sv);
3580     if (!ptr) {
3581         (void)SvOK_off(sv);
3582         return;
3583     }
3584     len = strlen(ptr);
3585     (void)SvUPGRADE(sv, SVt_PV);
3586
3587     SvGROW(sv, len + 1);
3588     Move(ptr,SvPVX(sv),len+1,char);
3589     SvCUR_set(sv, len);
3590     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3591     SvTAINT(sv);
3592 }
3593
3594 /*
3595 =for apidoc sv_setpv_mg
3596
3597 Like C<sv_setpv>, but also handles 'set' magic.
3598
3599 =cut
3600 */
3601
3602 void
3603 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3604 {
3605     sv_setpv(sv,ptr);
3606     SvSETMAGIC(sv);
3607 }
3608
3609 /*
3610 =for apidoc sv_usepvn
3611
3612 Tells an SV to use C<ptr> to find its string value.  Normally the string is
3613 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3614 The C<ptr> should point to memory that was allocated by C<malloc>.  The
3615 string length, C<len>, must be supplied.  This function will realloc the
3616 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3617 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
3618 See C<sv_usepvn_mg>.
3619
3620 =cut
3621 */
3622
3623 void
3624 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3625 {
3626     SV_CHECK_THINKFIRST(sv);
3627     (void)SvUPGRADE(sv, SVt_PV);
3628     if (!ptr) {
3629         (void)SvOK_off(sv);
3630         return;
3631     }
3632     (void)SvOOK_off(sv);
3633     if (SvPVX(sv) && SvLEN(sv))
3634         Safefree(SvPVX(sv));
3635     Renew(ptr, len+1, char);
3636     SvPVX(sv) = ptr;
3637     SvCUR_set(sv, len);
3638     SvLEN_set(sv, len+1);
3639     *SvEND(sv) = '\0';
3640     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3641     SvTAINT(sv);
3642 }
3643
3644 /*
3645 =for apidoc sv_usepvn_mg
3646
3647 Like C<sv_usepvn>, but also handles 'set' magic.
3648
3649 =cut
3650 */
3651
3652 void
3653 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3654 {
3655     sv_usepvn(sv,ptr,len);
3656     SvSETMAGIC(sv);
3657 }
3658
3659 void
3660 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3661 {
3662     if (SvREADONLY(sv)) {
3663         if (SvFAKE(sv)) {
3664             char *pvx = SvPVX(sv);
3665             STRLEN len = SvCUR(sv);
3666             U32 hash   = SvUVX(sv);
3667             SvGROW(sv, len + 1);
3668             Move(pvx,SvPVX(sv),len,char);
3669             *SvEND(sv) = '\0';
3670             SvFAKE_off(sv);
3671             SvREADONLY_off(sv);
3672             unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3673         }
3674         else if (PL_curcop != &PL_compiling)
3675             Perl_croak(aTHX_ PL_no_modify);
3676     }
3677     if (SvROK(sv))
3678         sv_unref_flags(sv, flags);
3679     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3680         sv_unglob(sv);
3681 }
3682
3683 void
3684 Perl_sv_force_normal(pTHX_ register SV *sv)
3685 {
3686     sv_force_normal_flags(sv, 0);
3687 }
3688
3689 /*
3690 =for apidoc sv_chop
3691
3692 Efficient removal of characters from the beginning of the string buffer.
3693 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3694 the string buffer.  The C<ptr> becomes the first character of the adjusted
3695 string.
3696
3697 =cut
3698 */
3699
3700 void
3701 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3702
3703
3704 {
3705     register STRLEN delta;
3706
3707     if (!ptr || !SvPOKp(sv))
3708         return;
3709     SV_CHECK_THINKFIRST(sv);
3710     if (SvTYPE(sv) < SVt_PVIV)
3711         sv_upgrade(sv,SVt_PVIV);
3712
3713     if (!SvOOK(sv)) {
3714         if (!SvLEN(sv)) { /* make copy of shared string */
3715             char *pvx = SvPVX(sv);
3716             STRLEN len = SvCUR(sv);
3717             SvGROW(sv, len + 1);
3718             Move(pvx,SvPVX(sv),len,char);
3719             *SvEND(sv) = '\0';
3720         }
3721         SvIVX(sv) = 0;
3722         SvFLAGS(sv) |= SVf_OOK;
3723     }
3724     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3725     delta = ptr - SvPVX(sv);
3726     SvLEN(sv) -= delta;
3727     SvCUR(sv) -= delta;
3728     SvPVX(sv) += delta;
3729     SvIVX(sv) += delta;
3730 }
3731
3732 /*
3733 =for apidoc sv_catpvn
3734
3735 Concatenates the string onto the end of the string which is in the SV.  The
3736 C<len> indicates number of bytes to copy.  Handles 'get' magic, but not
3737 'set' magic.  See C<sv_catpvn_mg>.
3738
3739 =cut
3740 */
3741
3742 void
3743 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3744 {
3745     STRLEN tlen;
3746     char *junk;
3747
3748     junk = SvPV_force(sv, tlen);
3749     SvGROW(sv, tlen + len + 1);
3750     if (ptr == junk)
3751         ptr = SvPVX(sv);
3752     Move(ptr,SvPVX(sv)+tlen,len,char);
3753     SvCUR(sv) += len;
3754     *SvEND(sv) = '\0';
3755     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3756     SvTAINT(sv);
3757 }
3758
3759 /*
3760 =for apidoc sv_catpvn_mg
3761
3762 Like C<sv_catpvn>, but also handles 'set' magic.
3763
3764 =cut
3765 */
3766
3767 void
3768 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3769 {
3770     sv_catpvn(sv,ptr,len);
3771     SvSETMAGIC(sv);
3772 }
3773
3774 /*
3775 =for apidoc sv_catsv
3776
3777 Concatenates the string from SV C<ssv> onto the end of the string in
3778 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
3779 not 'set' magic.  See C<sv_catsv_mg>.
3780
3781 =cut */
3782
3783 void
3784 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3785 {
3786     char *spv;
3787     STRLEN slen;
3788     if (!ssv)
3789         return;
3790     if ((spv = SvPV(ssv, slen))) {
3791         bool dutf8 = DO_UTF8(dsv);
3792         bool sutf8 = DO_UTF8(ssv);
3793
3794         if (dutf8 == sutf8)
3795             sv_catpvn(dsv,spv,slen);
3796         else {
3797             if (dutf8) {
3798                 /* Not modifying source SV, so taking a temporary copy. */
3799                 SV* csv = sv_2mortal(newSVsv(ssv));
3800                 char *cpv;
3801                 STRLEN clen;
3802
3803                 sv_utf8_upgrade(csv);
3804                 cpv = SvPV(csv,clen);
3805                 sv_catpvn(dsv,cpv,clen);
3806             }
3807             else {
3808                 sv_utf8_upgrade(dsv);
3809                 sv_catpvn(dsv,spv,slen);
3810                 SvUTF8_on(dsv); /* If dsv has no wide characters. */
3811             }
3812         }
3813     }
3814 }
3815
3816 /*
3817 =for apidoc sv_catsv_mg
3818
3819 Like C<sv_catsv>, but also handles 'set' magic.
3820
3821 =cut
3822 */
3823
3824 void
3825 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3826 {
3827     sv_catsv(dsv,ssv);
3828     SvSETMAGIC(dsv);
3829 }
3830
3831 /*
3832 =for apidoc sv_catpv
3833
3834 Concatenates the string onto the end of the string which is in the SV.
3835 Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
3836
3837 =cut
3838 */
3839
3840 void
3841 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3842 {
3843     register STRLEN len;
3844     STRLEN tlen;
3845     char *junk;
3846
3847     if (!ptr)
3848         return;
3849     junk = SvPV_force(sv, tlen);
3850     len = strlen(ptr);
3851     SvGROW(sv, tlen + len + 1);
3852     if (ptr == junk)
3853         ptr = SvPVX(sv);
3854     Move(ptr,SvPVX(sv)+tlen,len+1,char);
3855     SvCUR(sv) += len;
3856     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3857     SvTAINT(sv);
3858 }
3859
3860 /*
3861 =for apidoc sv_catpv_mg
3862
3863 Like C<sv_catpv>, but also handles 'set' magic.
3864
3865 =cut
3866 */
3867
3868 void
3869 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3870 {
3871     sv_catpv(sv,ptr);
3872     SvSETMAGIC(sv);
3873 }
3874
3875 SV *
3876 Perl_newSV(pTHX_ STRLEN len)
3877 {
3878     register SV *sv;
3879
3880     new_SV(sv);
3881     if (len) {
3882         sv_upgrade(sv, SVt_PV);
3883         SvGROW(sv, len + 1);
3884     }
3885     return sv;
3886 }
3887
3888 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3889
3890 /*
3891 =for apidoc sv_magic
3892
3893 Adds magic to an SV.
3894
3895 =cut
3896 */
3897
3898 void
3899 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3900 {
3901     MAGIC* mg;
3902
3903     if (SvREADONLY(sv)) {
3904         if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3905             Perl_croak(aTHX_ PL_no_modify);
3906     }
3907     if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3908         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3909             if (how == 't')
3910                 mg->mg_len |= 1;
3911             return;
3912         }
3913     }
3914     else {
3915         (void)SvUPGRADE(sv, SVt_PVMG);
3916     }
3917     Newz(702,mg, 1, MAGIC);
3918     mg->mg_moremagic = SvMAGIC(sv);
3919
3920     SvMAGIC(sv) = mg;
3921     if (!obj || obj == sv || how == '#' || how == 'r')
3922         mg->mg_obj = obj;
3923     else {
3924         mg->mg_obj = SvREFCNT_inc(obj);
3925         mg->mg_flags |= MGf_REFCOUNTED;
3926     }
3927     mg->mg_type = how;
3928     mg->mg_len = namlen;
3929     if (name)
3930         if (namlen >= 0)
3931             mg->mg_ptr = savepvn(name, namlen);
3932         else if (namlen == HEf_SVKEY)
3933             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3934
3935     switch (how) {
3936     case 0:
3937         mg->mg_virtual = &PL_vtbl_sv;
3938         break;
3939     case 'A':
3940         mg->mg_virtual = &PL_vtbl_amagic;
3941         break;
3942     case 'a':
3943         mg->mg_virtual = &PL_vtbl_amagicelem;
3944         break;
3945     case 'c':
3946         mg->mg_virtual = &PL_vtbl_ovrld;
3947         break;
3948     case 'B':
3949         mg->mg_virtual = &PL_vtbl_bm;
3950         break;
3951     case 'D':
3952         mg->mg_virtual = &PL_vtbl_regdata;
3953         break;
3954     case 'd':
3955         mg->mg_virtual = &PL_vtbl_regdatum;
3956         break;
3957     case 'E':
3958         mg->mg_virtual = &PL_vtbl_env;
3959         break;
3960     case 'f':
3961         mg->mg_virtual = &PL_vtbl_fm;
3962         break;
3963     case 'e':
3964         mg->mg_virtual = &PL_vtbl_envelem;
3965         break;
3966     case 'g':
3967         mg->mg_virtual = &PL_vtbl_mglob;
3968         break;
3969     case 'I':
3970         mg->mg_virtual = &PL_vtbl_isa;
3971         break;
3972     case 'i':
3973         mg->mg_virtual = &PL_vtbl_isaelem;
3974         break;
3975     case 'k':
3976         mg->mg_virtual = &PL_vtbl_nkeys;
3977         break;
3978     case 'L':
3979         SvRMAGICAL_on(sv);
3980         mg->mg_virtual = 0;
3981         break;
3982     case 'l':
3983         mg->mg_virtual = &PL_vtbl_dbline;
3984         break;
3985 #ifdef USE_THREADS
3986     case 'm':
3987         mg->mg_virtual = &PL_vtbl_mutex;
3988         break;
3989 #endif /* USE_THREADS */
3990 #ifdef USE_LOCALE_COLLATE
3991     case 'o':
3992         mg->mg_virtual = &PL_vtbl_collxfrm;
3993         break;
3994 #endif /* USE_LOCALE_COLLATE */
3995     case 'P':
3996         mg->mg_virtual = &PL_vtbl_pack;
3997         break;
3998     case 'p':
3999     case 'q':
4000         mg->mg_virtual = &PL_vtbl_packelem;
4001         break;
4002     case 'r':
4003         mg->mg_virtual = &PL_vtbl_regexp;
4004         break;
4005     case 'S':
4006         mg->mg_virtual = &PL_vtbl_sig;
4007         break;
4008     case 's':
4009         mg->mg_virtual = &PL_vtbl_sigelem;
4010         break;
4011     case 't':
4012         mg->mg_virtual = &PL_vtbl_taint;
4013         mg->mg_len = 1;
4014         break;
4015     case 'U':
4016         mg->mg_virtual = &PL_vtbl_uvar;
4017         break;
4018     case 'v':
4019         mg->mg_virtual = &PL_vtbl_vec;
4020         break;
4021     case 'x':
4022         mg->mg_virtual = &PL_vtbl_substr;
4023         break;
4024     case 'y':
4025         mg->mg_virtual = &PL_vtbl_defelem;
4026         break;
4027     case '*':
4028         mg->mg_virtual = &PL_vtbl_glob;
4029         break;
4030     case '#':
4031         mg->mg_virtual = &PL_vtbl_arylen;
4032         break;
4033     case '.':
4034         mg->mg_virtual = &PL_vtbl_pos;
4035         break;
4036     case '<':
4037         mg->mg_virtual = &PL_vtbl_backref;
4038         break;
4039     case '~':   /* Reserved for use by extensions not perl internals.   */
4040         /* Useful for attaching extension internal data to perl vars.   */
4041         /* Note that multiple extensions may clash if magical scalars   */
4042         /* etc holding private data from one are passed to another.     */
4043         SvRMAGICAL_on(sv);
4044         break;
4045     default:
4046         Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4047     }
4048     mg_magical(sv);
4049     if (SvGMAGICAL(sv))
4050         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4051 }
4052
4053 /*
4054 =for apidoc sv_unmagic
4055
4056 Removes magic from an SV.
4057
4058 =cut
4059 */
4060
4061 int
4062 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4063 {
4064     MAGIC* mg;
4065     MAGIC** mgp;
4066     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4067         return 0;
4068     mgp = &SvMAGIC(sv);
4069     for (mg = *mgp; mg; mg = *mgp) {
4070         if (mg->mg_type == type) {
4071             MGVTBL* vtbl = mg->mg_virtual;
4072             *mgp = mg->mg_moremagic;
4073             if (vtbl && vtbl->svt_free)
4074                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4075             if (mg->mg_ptr && mg->mg_type != 'g')
4076                 if (mg->mg_len >= 0)
4077                     Safefree(mg->mg_ptr);
4078                 else if (mg->mg_len == HEf_SVKEY)
4079                     SvREFCNT_dec((SV*)mg->mg_ptr);
4080             if (mg->mg_flags & MGf_REFCOUNTED)
4081                 SvREFCNT_dec(mg->mg_obj);
4082             Safefree(mg);
4083         }
4084         else
4085             mgp = &mg->mg_moremagic;
4086     }
4087     if (!SvMAGIC(sv)) {
4088         SvMAGICAL_off(sv);
4089         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4090     }
4091
4092     return 0;
4093 }
4094
4095 /*
4096 =for apidoc sv_rvweaken
4097
4098 Weaken a reference.
4099
4100 =cut
4101 */
4102
4103 SV *
4104 Perl_sv_rvweaken(pTHX_ SV *sv)
4105 {
4106     SV *tsv;
4107     if (!SvOK(sv))  /* let undefs pass */
4108         return sv;
4109     if (!SvROK(sv))
4110         Perl_croak(aTHX_ "Can't weaken a nonreference");
4111     else if (SvWEAKREF(sv)) {
4112         if (ckWARN(WARN_MISC))
4113             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4114         return sv;
4115     }
4116     tsv = SvRV(sv);
4117     sv_add_backref(tsv, sv);
4118     SvWEAKREF_on(sv);
4119     SvREFCNT_dec(tsv);
4120     return sv;
4121 }
4122
4123 STATIC void
4124 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4125 {
4126     AV *av;
4127     MAGIC *mg;
4128     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4129         av = (AV*)mg->mg_obj;
4130     else {
4131         av = newAV();
4132         sv_magic(tsv, (SV*)av, '<', NULL, 0);
4133         SvREFCNT_dec(av);           /* for sv_magic */
4134     }
4135     av_push(av,sv);
4136 }
4137
4138 STATIC void
4139 S_sv_del_backref(pTHX_ SV *sv)
4140 {
4141     AV *av;
4142     SV **svp;
4143     I32 i;
4144     SV *tsv = SvRV(sv);
4145     MAGIC *mg;
4146     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4147         Perl_croak(aTHX_ "panic: del_backref");
4148     av = (AV *)mg->mg_obj;
4149     svp = AvARRAY(av);
4150     i = AvFILLp(av);
4151     while (i >= 0) {
4152         if (svp[i] == sv) {
4153             svp[i] = &PL_sv_undef; /* XXX */
4154         }
4155         i--;
4156     }
4157 }
4158
4159 /*
4160 =for apidoc sv_insert
4161
4162 Inserts a string at the specified offset/length within the SV. Similar to
4163 the Perl substr() function.
4164
4165 =cut
4166 */
4167
4168 void
4169 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4170 {
4171     register char *big;
4172     register char *mid;
4173     register char *midend;
4174     register char *bigend;
4175     register I32 i;
4176     STRLEN curlen;
4177
4178
4179     if (!bigstr)
4180         Perl_croak(aTHX_ "Can't modify non-existent substring");
4181     SvPV_force(bigstr, curlen);
4182     (void)SvPOK_only_UTF8(bigstr);
4183     if (offset + len > curlen) {
4184         SvGROW(bigstr, offset+len+1);
4185         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4186         SvCUR_set(bigstr, offset+len);
4187     }
4188
4189     SvTAINT(bigstr);
4190     i = littlelen - len;
4191     if (i > 0) {                        /* string might grow */
4192         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4193         mid = big + offset + len;
4194         midend = bigend = big + SvCUR(bigstr);
4195         bigend += i;
4196         *bigend = '\0';
4197         while (midend > mid)            /* shove everything down */
4198             *--bigend = *--midend;
4199         Move(little,big+offset,littlelen,char);
4200         SvCUR(bigstr) += i;
4201         SvSETMAGIC(bigstr);
4202         return;
4203     }
4204     else if (i == 0) {
4205         Move(little,SvPVX(bigstr)+offset,len,char);
4206         SvSETMAGIC(bigstr);
4207         return;
4208     }
4209
4210     big = SvPVX(bigstr);
4211     mid = big + offset;
4212     midend = mid + len;
4213     bigend = big + SvCUR(bigstr);
4214
4215     if (midend > bigend)
4216         Perl_croak(aTHX_ "panic: sv_insert");
4217
4218     if (mid - big > bigend - midend) {  /* faster to shorten from end */
4219         if (littlelen) {
4220             Move(little, mid, littlelen,char);
4221             mid += littlelen;
4222         }
4223         i = bigend - midend;
4224         if (i > 0) {
4225             Move(midend, mid, i,char);
4226             mid += i;
4227         }
4228         *mid = '\0';
4229         SvCUR_set(bigstr, mid - big);
4230     }
4231     /*SUPPRESS 560*/
4232     else if ((i = mid - big)) { /* faster from front */
4233         midend -= littlelen;
4234         mid = midend;
4235         sv_chop(bigstr,midend-i);
4236         big += i;
4237         while (i--)
4238             *--midend = *--big;
4239         if (littlelen)
4240             Move(little, mid, littlelen,char);
4241     }
4242     else if (littlelen) {
4243         midend -= littlelen;
4244         sv_chop(bigstr,midend);
4245         Move(little,midend,littlelen,char);
4246     }
4247     else {
4248         sv_chop(bigstr,midend);
4249     }
4250     SvSETMAGIC(bigstr);
4251 }
4252
4253 /*
4254 =for apidoc sv_replace
4255
4256 Make the first argument a copy of the second, then delete the original.
4257
4258 =cut
4259 */
4260
4261 void
4262 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4263 {
4264     U32 refcnt = SvREFCNT(sv);
4265     SV_CHECK_THINKFIRST(sv);
4266     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4267         Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4268     if (SvMAGICAL(sv)) {
4269         if (SvMAGICAL(nsv))
4270             mg_free(nsv);
4271         else
4272             sv_upgrade(nsv, SVt_PVMG);
4273         SvMAGIC(nsv) = SvMAGIC(sv);
4274         SvFLAGS(nsv) |= SvMAGICAL(sv);
4275         SvMAGICAL_off(sv);
4276         SvMAGIC(sv) = 0;
4277     }
4278     SvREFCNT(sv) = 0;
4279     sv_clear(sv);
4280     assert(!SvREFCNT(sv));
4281     StructCopy(nsv,sv,SV);
4282     SvREFCNT(sv) = refcnt;
4283     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
4284     del_SV(nsv);
4285 }
4286
4287 /*
4288 =for apidoc sv_clear
4289
4290 Clear an SV, making it empty. Does not free the memory used by the SV
4291 itself.
4292
4293 =cut
4294 */
4295
4296 void
4297 Perl_sv_clear(pTHX_ register SV *sv)
4298 {
4299     HV* stash;
4300     assert(sv);
4301     assert(SvREFCNT(sv) == 0);
4302
4303     if (SvOBJECT(sv)) {
4304         if (PL_defstash) {              /* Still have a symbol table? */
4305             djSP;
4306             CV* destructor;
4307             SV tmpref;
4308
4309             Zero(&tmpref, 1, SV);
4310             sv_upgrade(&tmpref, SVt_RV);
4311             SvROK_on(&tmpref);
4312             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
4313             SvREFCNT(&tmpref) = 1;
4314
4315             do {
4316                 stash = SvSTASH(sv);
4317                 destructor = StashHANDLER(stash,DESTROY);
4318                 if (destructor) {
4319                     ENTER;
4320                     PUSHSTACKi(PERLSI_DESTROY);
4321                     SvRV(&tmpref) = SvREFCNT_inc(sv);
4322                     EXTEND(SP, 2);
4323                     PUSHMARK(SP);
4324                     PUSHs(&tmpref);
4325                     PUTBACK;
4326                     call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4327                     SvREFCNT(sv)--;
4328                     POPSTACK;
4329                     SPAGAIN;
4330                     LEAVE;
4331                 }
4332             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4333
4334             del_XRV(SvANY(&tmpref));
4335
4336             if (SvREFCNT(sv)) {
4337                 if (PL_in_clean_objs)
4338                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4339                           HvNAME(stash));
4340                 /* DESTROY gave object new lease on life */
4341                 return;
4342             }
4343         }
4344
4345         if (SvOBJECT(sv)) {
4346             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
4347             SvOBJECT_off(sv);   /* Curse the object. */
4348             if (SvTYPE(sv) != SVt_PVIO)
4349                 --PL_sv_objcount;       /* XXX Might want something more general */
4350         }
4351     }
4352     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4353         mg_free(sv);
4354     stash = NULL;
4355     switch (SvTYPE(sv)) {
4356     case SVt_PVIO:
4357         if (IoIFP(sv) &&
4358             IoIFP(sv) != PerlIO_stdin() &&
4359             IoIFP(sv) != PerlIO_stdout() &&
4360             IoIFP(sv) != PerlIO_stderr())
4361         {
4362             io_close((IO*)sv, FALSE);
4363         }
4364         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4365             PerlDir_close(IoDIRP(sv));
4366         IoDIRP(sv) = (DIR*)NULL;
4367         Safefree(IoTOP_NAME(sv));
4368         Safefree(IoFMT_NAME(sv));
4369         Safefree(IoBOTTOM_NAME(sv));
4370         /* FALL THROUGH */
4371     case SVt_PVBM:
4372         goto freescalar;
4373     case SVt_PVCV:
4374     case SVt_PVFM:
4375         cv_undef((CV*)sv);
4376         goto freescalar;
4377     case SVt_PVHV:
4378         hv_undef((HV*)sv);
4379         break;
4380     case SVt_PVAV:
4381         av_undef((AV*)sv);
4382         break;
4383     case SVt_PVLV:
4384         SvREFCNT_dec(LvTARG(sv));
4385         goto freescalar;
4386     case SVt_PVGV:
4387         gp_free((GV*)sv);
4388         Safefree(GvNAME(sv));
4389         /* cannot decrease stash refcount yet, as we might recursively delete
4390            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4391            of stash until current sv is completely gone.
4392            -- JohnPC, 27 Mar 1998 */
4393         stash = GvSTASH(sv);
4394         /* FALL THROUGH */
4395     case SVt_PVMG:
4396     case SVt_PVNV:
4397     case SVt_PVIV:
4398       freescalar:
4399         (void)SvOOK_off(sv);
4400         /* FALL THROUGH */
4401     case SVt_PV:
4402     case SVt_RV:
4403         if (SvROK(sv)) {
4404             if (SvWEAKREF(sv))
4405                 sv_del_backref(sv);
4406             else
4407                 SvREFCNT_dec(SvRV(sv));
4408         }
4409         else if (SvPVX(sv) && SvLEN(sv))
4410             Safefree(SvPVX(sv));
4411         else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4412             unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4413             SvFAKE_off(sv);
4414         }
4415         break;
4416 /*
4417     case SVt_NV:
4418     case SVt_IV:
4419     case SVt_NULL:
4420         break;
4421 */
4422     }
4423
4424     switch (SvTYPE(sv)) {
4425     case SVt_NULL:
4426         break;
4427     case SVt_IV:
4428         del_XIV(SvANY(sv));
4429         break;
4430     case SVt_NV:
4431         del_XNV(SvANY(sv));
4432         break;
4433     case SVt_RV:
4434         del_XRV(SvANY(sv));
4435         break;
4436     case SVt_PV:
4437         del_XPV(SvANY(sv));
4438         break;
4439     case SVt_PVIV:
4440         del_XPVIV(SvANY(sv));
4441         break;
4442     case SVt_PVNV:
4443         del_XPVNV(SvANY(sv));
4444         break;
4445     case SVt_PVMG:
4446         del_XPVMG(SvANY(sv));
4447         break;
4448     case SVt_PVLV:
4449         del_XPVLV(SvANY(sv));
4450         break;
4451     case SVt_PVAV:
4452         del_XPVAV(SvANY(sv));
4453         break;
4454     case SVt_PVHV:
4455         del_XPVHV(SvANY(sv));
4456         break;
4457     case SVt_PVCV:
4458         del_XPVCV(SvANY(sv));
4459         break;
4460     case SVt_PVGV:
4461         del_XPVGV(SvANY(sv));
4462         /* code duplication for increased performance. */
4463         SvFLAGS(sv) &= SVf_BREAK;
4464         SvFLAGS(sv) |= SVTYPEMASK;
4465         /* decrease refcount of the stash that owns this GV, if any */
4466         if (stash)
4467             SvREFCNT_dec(stash);
4468         return; /* not break, SvFLAGS reset already happened */
4469     case SVt_PVBM:
4470         del_XPVBM(SvANY(sv));
4471         break;
4472     case SVt_PVFM:
4473         del_XPVFM(SvANY(sv));
4474         break;
4475     case SVt_PVIO:
4476         del_XPVIO(SvANY(sv));
4477         break;
4478     }
4479     SvFLAGS(sv) &= SVf_BREAK;
4480     SvFLAGS(sv) |= SVTYPEMASK;
4481 }
4482
4483 SV *
4484 Perl_sv_newref(pTHX_ SV *sv)
4485 {
4486     if (sv)
4487         ATOMIC_INC(SvREFCNT(sv));
4488     return sv;
4489 }
4490
4491 /*
4492 =for apidoc sv_free
4493
4494 Free the memory used by an SV.
4495
4496 =cut
4497 */
4498
4499 void
4500 Perl_sv_free(pTHX_ SV *sv)
4501 {
4502     int refcount_is_zero;
4503
4504     if (!sv)
4505         return;
4506     if (SvREFCNT(sv) == 0) {
4507         if (SvFLAGS(sv) & SVf_BREAK)
4508             return;
4509         if (PL_in_clean_all) /* All is fair */
4510             return;
4511         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4512             /* make sure SvREFCNT(sv)==0 happens very seldom */
4513             SvREFCNT(sv) = (~(U32)0)/2;
4514             return;
4515         }
4516         if (ckWARN_d(WARN_INTERNAL))
4517             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4518         return;
4519     }
4520     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4521     if (!refcount_is_zero)
4522         return;
4523 #ifdef DEBUGGING
4524     if (SvTEMP(sv)) {
4525         if (ckWARN_d(WARN_DEBUGGING))
4526             Perl_warner(aTHX_ WARN_DEBUGGING,
4527                         "Attempt to free temp prematurely: SV 0x%"UVxf,
4528                         PTR2UV(sv));
4529         return;
4530     }
4531 #endif
4532     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4533         /* make sure SvREFCNT(sv)==0 happens very seldom */
4534         SvREFCNT(sv) = (~(U32)0)/2;
4535         return;
4536     }
4537     sv_clear(sv);
4538     if (! SvREFCNT(sv))
4539         del_SV(sv);
4540 }
4541
4542 /*
4543 =for apidoc sv_len
4544
4545 Returns the length of the string in the SV.  See also C<SvCUR>.
4546
4547 =cut
4548 */
4549
4550 STRLEN
4551 Perl_sv_len(pTHX_ register SV *sv)
4552 {
4553     char *junk;
4554     STRLEN len;
4555
4556     if (!sv)
4557         return 0;
4558
4559     if (SvGMAGICAL(sv))
4560         len = mg_length(sv);
4561     else
4562         junk = SvPV(sv, len);
4563     return len;
4564 }
4565
4566 /*
4567 =for apidoc sv_len_utf8
4568
4569 Returns the number of characters in the string in an SV, counting wide
4570 UTF8 bytes as a single character.
4571
4572 =cut
4573 */
4574
4575 STRLEN
4576 Perl_sv_len_utf8(pTHX_ register SV *sv)
4577 {
4578     if (!sv)
4579         return 0;
4580
4581     if (SvGMAGICAL(sv))
4582         return mg_length(sv);
4583     else
4584     {
4585         STRLEN len;
4586         U8 *s = (U8*)SvPV(sv, len);
4587
4588         return Perl_utf8_length(aTHX_ s, s + len);
4589     }
4590 }
4591
4592 void
4593 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4594 {
4595     U8 *start;
4596     U8 *s;
4597     U8 *send;
4598     I32 uoffset = *offsetp;
4599     STRLEN len;
4600
4601     if (!sv)
4602         return;
4603
4604     start = s = (U8*)SvPV(sv, len);
4605     send = s + len;
4606     while (s < send && uoffset--)
4607         s += UTF8SKIP(s);
4608     if (s >= send)
4609         s = send;
4610     *offsetp = s - start;
4611     if (lenp) {
4612         I32 ulen = *lenp;
4613         start = s;
4614         while (s < send && ulen--)
4615             s += UTF8SKIP(s);
4616         if (s >= send)
4617             s = send;
4618         *lenp = s - start;
4619     }
4620     return;
4621 }
4622
4623 void
4624 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4625 {
4626     U8 *s;
4627     U8 *send;
4628     STRLEN len;
4629
4630     if (!sv)
4631         return;
4632
4633     s = (U8*)SvPV(sv, len);
4634     if (len < *offsetp)
4635         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4636     send = s + *offsetp;
4637     len = 0;
4638     while (s < send) {
4639         STRLEN n;
4640
4641         if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) {
4642             s += n;
4643             len++;
4644         }
4645         else
4646             break;
4647     }
4648     *offsetp = len;
4649     return;
4650 }
4651
4652 /*
4653 =for apidoc sv_eq
4654
4655 Returns a boolean indicating whether the strings in the two SVs are
4656 identical.
4657
4658 =cut
4659 */
4660
4661 I32
4662 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4663 {
4664     char *pv1;
4665     STRLEN cur1;
4666     char *pv2;
4667     STRLEN cur2;
4668     I32  eq     = 0;
4669     bool pv1tmp = FALSE;
4670     bool pv2tmp = FALSE;
4671
4672     if (!sv1) {
4673         pv1 = "";
4674         cur1 = 0;
4675     }
4676     else
4677         pv1 = SvPV(sv1, cur1);
4678
4679     if (!sv2){
4680         pv2 = "";
4681         cur2 = 0;
4682     }
4683     else
4684         pv2 = SvPV(sv2, cur2);
4685
4686     /* do not utf8ize the comparands as a side-effect */
4687     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4688         if (PL_hints & HINT_UTF8_DISTINCT)
4689             return FALSE;
4690
4691         if (SvUTF8(sv1)) {
4692             (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
4693             {
4694                 IV scur1 = cur1;
4695                 if (scur1 < 0) {
4696                     Safefree(pv1);
4697                     return 0;
4698                 }
4699             }
4700             pv1tmp = TRUE;
4701         }
4702         else {
4703             (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
4704             {
4705                 IV scur2 = cur2;
4706                 if (scur2 < 0) {
4707                     Safefree(pv2);
4708                     return 0;
4709                 }
4710             }
4711             pv2tmp = TRUE;
4712         }
4713     }
4714
4715     if (cur1 == cur2)
4716         eq = memEQ(pv1, pv2, cur1);
4717
4718     if (pv1tmp)
4719         Safefree(pv1);
4720     if (pv2tmp)
4721         Safefree(pv2);
4722
4723     return eq;
4724 }
4725
4726 /*
4727 =for apidoc sv_cmp
4728
4729 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
4730 string in C<sv1> is less than, equal to, or greater than the string in
4731 C<sv2>.
4732
4733 =cut
4734 */
4735
4736 I32
4737 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4738 {
4739     STRLEN cur1, cur2;
4740     char *pv1, *pv2;
4741     I32  cmp;
4742     bool pv1tmp = FALSE;
4743     bool pv2tmp = FALSE;
4744
4745     if (!sv1) {
4746         pv1 = "";
4747         cur1 = 0;
4748     }
4749     else
4750         pv1 = SvPV(sv1, cur1);
4751
4752     if (!sv2){
4753         pv2 = "";
4754         cur2 = 0;
4755     }
4756     else
4757         pv2 = SvPV(sv2, cur2);
4758
4759     /* do not utf8ize the comparands as a side-effect */
4760     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4761         if (PL_hints & HINT_UTF8_DISTINCT)
4762             return SvUTF8(sv1) ? 1 : -1;
4763
4764         if (SvUTF8(sv1)) {
4765             pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4766             pv2tmp = TRUE;
4767         }
4768         else {
4769             pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4770             pv1tmp = TRUE;
4771         }
4772     }
4773
4774     if (!cur1) {
4775         cmp = cur2 ? -1 : 0;
4776     } else if (!cur2) {
4777         cmp = 1;
4778     } else {
4779         I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4780
4781         if (retval) {
4782             cmp = retval < 0 ? -1 : 1;
4783         } else if (cur1 == cur2) {
4784             cmp = 0;
4785         } else {
4786             cmp = cur1 < cur2 ? -1 : 1;
4787         }
4788     }
4789
4790     if (pv1tmp)
4791         Safefree(pv1);
4792     if (pv2tmp)
4793         Safefree(pv2);
4794
4795     return cmp;
4796 }
4797
4798 /*
4799 =for apidoc sv_cmp_locale
4800
4801 Compares the strings in two SVs in a locale-aware manner. See
4802 L</sv_cmp_locale>
4803
4804 =cut
4805 */
4806
4807 I32
4808 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4809 {
4810 #ifdef USE_LOCALE_COLLATE
4811
4812     char *pv1, *pv2;
4813     STRLEN len1, len2;
4814     I32 retval;
4815
4816     if (PL_collation_standard)
4817         goto raw_compare;
4818
4819     len1 = 0;
4820     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4821     len2 = 0;
4822     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4823
4824     if (!pv1 || !len1) {
4825         if (pv2 && len2)
4826             return -1;
4827         else
4828             goto raw_compare;
4829     }
4830     else {
4831         if (!pv2 || !len2)
4832             return 1;
4833     }
4834
4835     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4836
4837     if (retval)
4838         return retval < 0 ? -1 : 1;
4839
4840     /*
4841      * When the result of collation is equality, that doesn't mean
4842      * that there are no differences -- some locales exclude some
4843      * characters from consideration.  So to avoid false equalities,
4844      * we use the raw string as a tiebreaker.
4845      */
4846
4847   raw_compare:
4848     /* FALL THROUGH */
4849
4850 #endif /* USE_LOCALE_COLLATE */
4851
4852     return sv_cmp(sv1, sv2);
4853 }
4854
4855 #ifdef USE_LOCALE_COLLATE
4856 /*
4857  * Any scalar variable may carry an 'o' magic that contains the
4858  * scalar data of the variable transformed to such a format that
4859  * a normal memory comparison can be used to compare the data
4860  * according to the locale settings.
4861  */
4862 char *
4863 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4864 {
4865     MAGIC *mg;
4866
4867     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4868     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4869         char *s, *xf;
4870         STRLEN len, xlen;
4871
4872         if (mg)
4873             Safefree(mg->mg_ptr);
4874         s = SvPV(sv, len);
4875         if ((xf = mem_collxfrm(s, len, &xlen))) {
4876             if (SvREADONLY(sv)) {
4877                 SAVEFREEPV(xf);
4878                 *nxp = xlen;
4879                 return xf + sizeof(PL_collation_ix);
4880             }
4881             if (! mg) {
4882                 sv_magic(sv, 0, 'o', 0, 0);
4883                 mg = mg_find(sv, 'o');
4884                 assert(mg);
4885             }
4886             mg->mg_ptr = xf;
4887             mg->mg_len = xlen;
4888         }
4889         else {
4890             if (mg) {
4891                 mg->mg_ptr = NULL;
4892                 mg->mg_len = -1;
4893             }
4894         }
4895     }
4896     if (mg && mg->mg_ptr) {
4897         *nxp = mg->mg_len;
4898         return mg->mg_ptr + sizeof(PL_collation_ix);
4899     }
4900     else {
4901         *nxp = 0;
4902         return NULL;
4903     }
4904 }
4905
4906 #endif /* USE_LOCALE_COLLATE */
4907
4908 /*
4909 =for apidoc sv_gets
4910
4911 Get a line from the filehandle and store it into the SV, optionally
4912 appending to the currently-stored string.
4913
4914 =cut
4915 */
4916
4917 char *
4918 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4919 {
4920     char *rsptr;
4921     STRLEN rslen;
4922     register STDCHAR rslast;
4923     register STDCHAR *bp;
4924     register I32 cnt;
4925     I32 i;
4926
4927     SV_CHECK_THINKFIRST(sv);
4928     (void)SvUPGRADE(sv, SVt_PV);
4929
4930     SvSCREAM_off(sv);
4931
4932     if (RsSNARF(PL_rs)) {
4933         rsptr = NULL;
4934         rslen = 0;
4935     }
4936     else if (RsRECORD(PL_rs)) {
4937       I32 recsize, bytesread;
4938       char *buffer;
4939
4940       /* Grab the size of the record we're getting */
4941       recsize = SvIV(SvRV(PL_rs));
4942       (void)SvPOK_only(sv);    /* Validate pointer */
4943       buffer = SvGROW(sv, recsize + 1);
4944       /* Go yank in */
4945 #ifdef VMS
4946       /* VMS wants read instead of fread, because fread doesn't respect */
4947       /* RMS record boundaries. This is not necessarily a good thing to be */
4948       /* doing, but we've got no other real choice */
4949       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4950 #else
4951       bytesread = PerlIO_read(fp, buffer, recsize);
4952 #endif
4953       SvCUR_set(sv, bytesread);
4954       buffer[bytesread] = '\0';
4955       if (PerlIO_isutf8(fp))
4956         SvUTF8_on(sv);
4957       else
4958         SvUTF8_off(sv);
4959       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4960     }
4961     else if (RsPARA(PL_rs)) {
4962         rsptr = "\n\n";
4963         rslen = 2;
4964     }
4965     else {
4966         /* Get $/ i.e. PL_rs into same encoding as stream wants */
4967         if (PerlIO_isutf8(fp)) {
4968             rsptr = SvPVutf8(PL_rs, rslen);
4969         }
4970         else {
4971             if (SvUTF8(PL_rs)) {
4972                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4973                     Perl_croak(aTHX_ "Wide character in $/");
4974                 }
4975             }
4976             rsptr = SvPV(PL_rs, rslen);
4977         }
4978     }
4979
4980     rslast = rslen ? rsptr[rslen - 1] : '\0';
4981
4982     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
4983         do {                    /* to make sure file boundaries work right */
4984             if (PerlIO_eof(fp))
4985                 return 0;
4986             i = PerlIO_getc(fp);
4987             if (i != '\n') {
4988                 if (i == -1)
4989                     return 0;
4990                 PerlIO_ungetc(fp,i);
4991                 break;
4992             }
4993         } while (i != EOF);
4994     }
4995
4996     /* See if we know enough about I/O mechanism to cheat it ! */
4997
4998     /* This used to be #ifdef test - it is made run-time test for ease
4999        of abstracting out stdio interface. One call should be cheap
5000        enough here - and may even be a macro allowing compile
5001        time optimization.
5002      */
5003
5004     if (PerlIO_fast_gets(fp)) {
5005
5006     /*
5007      * We're going to steal some values from the stdio struct
5008      * and put EVERYTHING in the innermost loop into registers.
5009      */
5010     register STDCHAR *ptr;
5011     STRLEN bpx;
5012     I32 shortbuffered;
5013
5014 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5015     /* An ungetc()d char is handled separately from the regular
5016      * buffer, so we getc() it back out and stuff it in the buffer.
5017      */
5018     i = PerlIO_getc(fp);
5019     if (i == EOF) return 0;
5020     *(--((*fp)->_ptr)) = (unsigned char) i;
5021     (*fp)->_cnt++;
5022 #endif
5023
5024     /* Here is some breathtakingly efficient cheating */
5025
5026     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
5027     (void)SvPOK_only(sv);               /* validate pointer */
5028     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5029         if (cnt > 80 && SvLEN(sv) > append) {
5030             shortbuffered = cnt - SvLEN(sv) + append + 1;
5031             cnt -= shortbuffered;
5032         }
5033         else {
5034             shortbuffered = 0;
5035             /* remember that cnt can be negative */
5036             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5037         }
5038     }
5039     else
5040         shortbuffered = 0;
5041     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
5042     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5043     DEBUG_P(PerlIO_printf(Perl_debug_log,
5044         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5045     DEBUG_P(PerlIO_printf(Perl_debug_log,
5046         "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5047                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5048                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5049     for (;;) {
5050       screamer:
5051         if (cnt > 0) {
5052             if (rslen) {
5053                 while (cnt > 0) {                    /* this     |  eat */
5054                     cnt--;
5055                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
5056                         goto thats_all_folks;        /* screams  |  sed :-) */
5057                 }
5058             }
5059             else {
5060                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
5061                 bp += cnt;                           /* screams  |  dust */
5062                 ptr += cnt;                          /* louder   |  sed :-) */
5063                 cnt = 0;
5064             }
5065         }
5066
5067         if (shortbuffered) {            /* oh well, must extend */
5068             cnt = shortbuffered;
5069             shortbuffered = 0;
5070             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5071             SvCUR_set(sv, bpx);
5072             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5073             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5074             continue;
5075         }
5076
5077         DEBUG_P(PerlIO_printf(Perl_debug_log,
5078                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5079                               PTR2UV(ptr),(long)cnt));
5080         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5081         DEBUG_P(PerlIO_printf(Perl_debug_log,
5082             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5083             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5084             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5085         /* This used to call 'filbuf' in stdio form, but as that behaves like
5086            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5087            another abstraction.  */
5088         i   = PerlIO_getc(fp);          /* get more characters */
5089         DEBUG_P(PerlIO_printf(Perl_debug_log,
5090             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5091             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5092             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5093         cnt = PerlIO_get_cnt(fp);
5094         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
5095         DEBUG_P(PerlIO_printf(Perl_debug_log,
5096             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5097
5098         if (i == EOF)                   /* all done for ever? */
5099             goto thats_really_all_folks;
5100
5101         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5102         SvCUR_set(sv, bpx);
5103         SvGROW(sv, bpx + cnt + 2);
5104         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5105
5106         *bp++ = i;                      /* store character from PerlIO_getc */
5107
5108         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
5109             goto thats_all_folks;
5110     }
5111
5112 thats_all_folks:
5113     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5114           memNE((char*)bp - rslen, rsptr, rslen))
5115         goto screamer;                          /* go back to the fray */
5116 thats_really_all_folks:
5117     if (shortbuffered)
5118         cnt += shortbuffered;
5119         DEBUG_P(PerlIO_printf(Perl_debug_log,
5120             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5121     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
5122     DEBUG_P(PerlIO_printf(Perl_debug_log,
5123         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5124         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5125         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5126     *bp = '\0';
5127     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
5128     DEBUG_P(PerlIO_printf(Perl_debug_log,
5129         "Screamer: done, len=%ld, string=|%.*s|\n",
5130         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5131     }
5132    else
5133     {
5134 #ifndef EPOC
5135        /*The big, slow, and stupid way */
5136         STDCHAR buf[8192];
5137 #else
5138         /* Need to work around EPOC SDK features          */
5139         /* On WINS: MS VC5 generates calls to _chkstk,    */
5140         /* if a `large' stack frame is allocated          */
5141         /* gcc on MARM does not generate calls like these */
5142         STDCHAR buf[1024];
5143 #endif
5144
5145 screamer2:
5146         if (rslen) {
5147             register STDCHAR *bpe = buf + sizeof(buf);
5148             bp = buf;
5149             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5150                 ; /* keep reading */
5151             cnt = bp - buf;
5152         }
5153         else {
5154             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5155             /* Accomodate broken VAXC compiler, which applies U8 cast to
5156              * both args of ?: operator, causing EOF to change into 255
5157              */
5158             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5159         }
5160
5161         if (append)
5162             sv_catpvn(sv, (char *) buf, cnt);
5163         else
5164             sv_setpvn(sv, (char *) buf, cnt);
5165
5166         if (i != EOF &&                 /* joy */
5167             (!rslen ||
5168              SvCUR(sv) < rslen ||
5169              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5170         {
5171             append = -1;
5172             /*
5173              * If we're reading from a TTY and we get a short read,
5174              * indicating that the user hit his EOF character, we need
5175              * to notice it now, because if we try to read from the TTY
5176              * again, the EOF condition will disappear.
5177              *
5178              * The comparison of cnt to sizeof(buf) is an optimization
5179              * that prevents unnecessary calls to feof().
5180              *
5181              * - jik 9/25/96
5182              */
5183             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5184                 goto screamer2;
5185         }
5186     }
5187
5188     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
5189         while (i != EOF) {      /* to make sure file boundaries work right */
5190             i = PerlIO_getc(fp);
5191             if (i != '\n') {
5192                 PerlIO_ungetc(fp,i);
5193                 break;
5194             }
5195         }
5196     }
5197
5198     if (PerlIO_isutf8(fp))
5199         SvUTF8_on(sv);
5200     else
5201         SvUTF8_off(sv);
5202
5203     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5204 }
5205
5206
5207 /*
5208 =for apidoc sv_inc
5209
5210 Auto-increment of the value in the SV.
5211
5212 =cut
5213 */
5214
5215 void
5216 Perl_sv_inc(pTHX_ register SV *sv)
5217 {
5218     register char *d;
5219     int flags;
5220
5221     if (!sv)
5222         return;
5223     if (SvGMAGICAL(sv))
5224         mg_get(sv);
5225     if (SvTHINKFIRST(sv)) {
5226         if (SvREADONLY(sv)) {
5227             if (PL_curcop != &PL_compiling)
5228                 Perl_croak(aTHX_ PL_no_modify);
5229         }
5230         if (SvROK(sv)) {
5231             IV i;
5232             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5233                 return;
5234             i = PTR2IV(SvRV(sv));
5235             sv_unref(sv);
5236             sv_setiv(sv, i);
5237         }
5238     }
5239     flags = SvFLAGS(sv);
5240     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5241         /* It's (privately or publicly) a float, but not tested as an
5242            integer, so test it to see. */
5243         (void) SvIV(sv);
5244         flags = SvFLAGS(sv);
5245     }
5246     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5247         /* It's publicly an integer, or privately an integer-not-float */
5248       oops_its_int:
5249         if (SvIsUV(sv)) {
5250             if (SvUVX(sv) == UV_MAX)
5251                 sv_setnv(sv, (NV)UV_MAX + 1.0);
5252             else
5253                 (void)SvIOK_only_UV(sv);
5254                 ++SvUVX(sv);
5255         } else {
5256             if (SvIVX(sv) == IV_MAX)
5257                 sv_setuv(sv, (UV)IV_MAX + 1);
5258             else {
5259                 (void)SvIOK_only(sv);
5260                 ++SvIVX(sv);
5261             }
5262         }
5263         return;
5264     }
5265     if (flags & SVp_NOK) {
5266         (void)SvNOK_only(sv);
5267         SvNVX(sv) += 1.0;
5268         return;
5269     }
5270
5271     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5272         if ((flags & SVTYPEMASK) < SVt_PVIV)
5273             sv_upgrade(sv, SVt_IV);
5274         (void)SvIOK_only(sv);
5275         SvIVX(sv) = 1;
5276         return;
5277     }
5278     d = SvPVX(sv);
5279     while (isALPHA(*d)) d++;
5280     while (isDIGIT(*d)) d++;
5281     if (*d) {
5282 #ifdef PERL_PRESERVE_IVUV
5283         /* Got to punt this an an integer if needs be, but we don't issue
5284            warnings. Probably ought to make the sv_iv_please() that does
5285            the conversion if possible, and silently.  */
5286         I32 numtype = looks_like_number(sv);
5287         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5288             /* Need to try really hard to see if it's an integer.
5289                9.22337203685478e+18 is an integer.
5290                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5291                so $a="9.22337203685478e+18"; $a+0; $a++
5292                needs to be the same as $a="9.22337203685478e+18"; $a++
5293                or we go insane. */
5294
5295             (void) sv_2iv(sv);
5296             if (SvIOK(sv))
5297                 goto oops_its_int;
5298
5299             /* sv_2iv *should* have made this an NV */
5300             if (flags & SVp_NOK) {
5301                 (void)SvNOK_only(sv);
5302                 SvNVX(sv) += 1.0;
5303                 return;
5304             }
5305             /* I don't think we can get here. Maybe I should assert this
5306                And if we do get here I suspect that sv_setnv will croak. NWC
5307                Fall through. */
5308 #if defined(USE_LONG_DOUBLE)
5309             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
5310                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5311 #else
5312             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5313                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5314 #endif
5315         }
5316 #endif /* PERL_PRESERVE_IVUV */
5317         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5318         return;
5319     }
5320     d--;
5321     while (d >= SvPVX(sv)) {
5322         if (isDIGIT(*d)) {
5323             if (++*d <= '9')
5324                 return;
5325             *(d--) = '0';
5326         }
5327         else {
5328 #ifdef EBCDIC
5329             /* MKS: The original code here died if letters weren't consecutive.
5330              * at least it didn't have to worry about non-C locales.  The
5331              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5332              * arranged in order (although not consecutively) and that only
5333              * [A-Za-z] are accepted by isALPHA in the C locale.
5334              */
5335             if (*d != 'z' && *d != 'Z') {
5336                 do { ++*d; } while (!isALPHA(*d));
5337                 return;
5338             }
5339             *(d--) -= 'z' - 'a';
5340 #else
5341             ++*d;
5342             if (isALPHA(*d))
5343                 return;
5344             *(d--) -= 'z' - 'a' + 1;
5345 #endif
5346         }
5347     }
5348     /* oh,oh, the number grew */
5349     SvGROW(sv, SvCUR(sv) + 2);
5350     SvCUR(sv)++;
5351     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5352         *d = d[-1];
5353     if (isDIGIT(d[1]))
5354         *d = '1';
5355     else
5356         *d = d[1];
5357 }
5358
5359 /*
5360 =for apidoc sv_dec
5361
5362 Auto-decrement of the value in the SV.
5363
5364 =cut
5365 */
5366
5367 void
5368 Perl_sv_dec(pTHX_ register SV *sv)
5369 {
5370     int flags;
5371
5372     if (!sv)
5373         return;
5374     if (SvGMAGICAL(sv))
5375         mg_get(sv);
5376     if (SvTHINKFIRST(sv)) {
5377         if (SvREADONLY(sv)) {
5378             if (PL_curcop != &PL_compiling)
5379                 Perl_croak(aTHX_ PL_no_modify);
5380         }
5381         if (SvROK(sv)) {
5382             IV i;
5383             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5384                 return;
5385             i = PTR2IV(SvRV(sv));
5386             sv_unref(sv);
5387             sv_setiv(sv, i);
5388         }
5389     }
5390     /* Unlike sv_inc we don't have to worry about string-never-numbers
5391        and keeping them magic. But we mustn't warn on punting */
5392     flags = SvFLAGS(sv);
5393     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5394         /* It's publicly an integer, or privately an integer-not-float */
5395       oops_its_int:
5396         if (SvIsUV(sv)) {
5397             if (SvUVX(sv) == 0) {
5398                 (void)SvIOK_only(sv);
5399                 SvIVX(sv) = -1;
5400             }
5401             else {
5402                 (void)SvIOK_only_UV(sv);
5403                 --SvUVX(sv);
5404             }
5405         } else {
5406             if (SvIVX(sv) == IV_MIN)
5407                 sv_setnv(sv, (NV)IV_MIN - 1.0);
5408             else {
5409                 (void)SvIOK_only(sv);
5410                 --SvIVX(sv);
5411             }
5412         }
5413         return;
5414     }
5415     if (flags & SVp_NOK) {
5416         SvNVX(sv) -= 1.0;
5417         (void)SvNOK_only(sv);
5418         return;
5419     }
5420     if (!(flags & SVp_POK)) {
5421         if ((flags & SVTYPEMASK) < SVt_PVNV)
5422             sv_upgrade(sv, SVt_NV);
5423         SvNVX(sv) = -1.0;
5424         (void)SvNOK_only(sv);
5425         return;
5426     }
5427 #ifdef PERL_PRESERVE_IVUV
5428     {
5429         I32 numtype = looks_like_number(sv);
5430         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5431             /* Need to try really hard to see if it's an integer.
5432                9.22337203685478e+18 is an integer.
5433                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5434                so $a="9.22337203685478e+18"; $a+0; $a--
5435                needs to be the same as $a="9.22337203685478e+18"; $a--
5436                or we go insane. */
5437
5438             (void) sv_2iv(sv);
5439             if (SvIOK(sv))
5440                 goto oops_its_int;
5441
5442             /* sv_2iv *should* have made this an NV */
5443             if (flags & SVp_NOK) {
5444                 (void)SvNOK_only(sv);
5445                 SvNVX(sv) -= 1.0;
5446                 return;
5447             }
5448             /* I don't think we can get here. Maybe I should assert this
5449                And if we do get here I suspect that sv_setnv will croak. NWC
5450                Fall through. */
5451 #if defined(USE_LONG_DOUBLE)
5452             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
5453                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5454 #else
5455             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5456                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5457 #endif
5458         }
5459     }
5460 #endif /* PERL_PRESERVE_IVUV */
5461     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5462 }
5463
5464 /*
5465 =for apidoc sv_mortalcopy
5466
5467 Creates a new SV which is a copy of the original SV.  The new SV is marked
5468 as mortal.
5469
5470 =cut
5471 */
5472
5473 /* Make a string that will exist for the duration of the expression
5474  * evaluation.  Actually, it may have to last longer than that, but
5475  * hopefully we won't free it until it has been assigned to a
5476  * permanent location. */
5477
5478 SV *
5479 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5480 {
5481     register SV *sv;
5482
5483     new_SV(sv);
5484     sv_setsv(sv,oldstr);
5485     EXTEND_MORTAL(1);
5486     PL_tmps_stack[++PL_tmps_ix] = sv;
5487     SvTEMP_on(sv);
5488     return sv;
5489 }
5490
5491 /*
5492 =for apidoc sv_newmortal
5493
5494 Creates a new SV which is mortal.  The reference count of the SV is set to 1.
5495
5496 =cut
5497 */
5498
5499 SV *
5500 Perl_sv_newmortal(pTHX)
5501 {
5502     register SV *sv;
5503
5504     new_SV(sv);
5505     SvFLAGS(sv) = SVs_TEMP;
5506     EXTEND_MORTAL(1);
5507     PL_tmps_stack[++PL_tmps_ix] = sv;
5508     return sv;
5509 }
5510
5511 /*
5512 =for apidoc sv_2mortal
5513
5514 Marks an SV as mortal.  The SV will be destroyed when the current context
5515 ends.
5516
5517 =cut
5518 */
5519
5520 /* same thing without the copying */
5521
5522 SV *
5523 Perl_sv_2mortal(pTHX_ register SV *sv)
5524 {
5525     if (!sv)
5526         return sv;
5527     if (SvREADONLY(sv) && SvIMMORTAL(sv))
5528         return sv;
5529     EXTEND_MORTAL(1);
5530     PL_tmps_stack[++PL_tmps_ix] = sv;
5531     SvTEMP_on(sv);
5532     return sv;
5533 }
5534
5535 /*
5536 =for apidoc newSVpv
5537
5538 Creates a new SV and copies a string into it.  The reference count for the
5539 SV is set to 1.  If C<len> is zero, Perl will compute the length using
5540 strlen().  For efficiency, consider using C<newSVpvn> instead.
5541
5542 =cut
5543 */
5544
5545 SV *
5546 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5547 {
5548     register SV *sv;
5549
5550     new_SV(sv);
5551     if (!len)
5552         len = strlen(s);
5553     sv_setpvn(sv,s,len);
5554     return sv;
5555 }
5556
5557 /*
5558 =for apidoc newSVpvn
5559
5560 Creates a new SV and copies a string into it.  The reference count for the
5561 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
5562 string.  You are responsible for ensuring that the source string is at least
5563 C<len> bytes long.
5564
5565 =cut
5566 */
5567
5568 SV *
5569 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5570 {
5571     register SV *sv;
5572
5573     new_SV(sv);
5574     sv_setpvn(sv,s,len);
5575     return sv;
5576 }
5577
5578 /*
5579 =for apidoc newSVpvn_share
5580
5581 Creates a new SV and populates it with a string from
5582 the string table. Turns on READONLY and FAKE.
5583 The idea here is that as string table is used for shared hash
5584 keys these strings will have SvPVX == HeKEY and hash lookup
5585 will avoid string compare.
5586
5587 =cut
5588 */
5589
5590 SV *
5591 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5592 {
5593     register SV *sv;
5594     bool is_utf8 = FALSE;
5595     if (len < 0) {
5596         len = -len;
5597         is_utf8 = TRUE;
5598     }
5599     if (!hash)
5600         PERL_HASH(hash, src, len);
5601     new_SV(sv);
5602     sv_upgrade(sv, SVt_PVIV);
5603     SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5604     SvCUR(sv) = len;
5605     SvUVX(sv) = hash;
5606     SvLEN(sv) = 0;
5607     SvREADONLY_on(sv);
5608     SvFAKE_on(sv);
5609     SvPOK_on(sv);
5610     if (is_utf8)
5611         SvUTF8_on(sv);
5612     return sv;
5613 }
5614
5615 #if defined(PERL_IMPLICIT_CONTEXT)
5616 SV *
5617 Perl_newSVpvf_nocontext(const char* pat, ...)
5618 {
5619     dTHX;
5620     register SV *sv;
5621     va_list args;
5622     va_start(args, pat);
5623     sv = vnewSVpvf(pat, &args);
5624     va_end(args);
5625     return sv;
5626 }
5627 #endif
5628
5629 /*
5630 =for apidoc newSVpvf
5631
5632 Creates a new SV an initialize it with the string formatted like
5633 C<sprintf>.
5634
5635 =cut
5636 */
5637
5638 SV *
5639 Perl_newSVpvf(pTHX_ const char* pat, ...)
5640 {
5641     register SV *sv;
5642     va_list args;
5643     va_start(args, pat);
5644     sv = vnewSVpvf(pat, &args);
5645     va_end(args);
5646     return sv;
5647 }
5648
5649 SV *
5650 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5651 {
5652     register SV *sv;
5653     new_SV(sv);
5654     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5655     return sv;
5656 }
5657
5658 /*
5659 =for apidoc newSVnv
5660
5661 Creates a new SV and copies a floating point value into it.
5662 The reference count for the SV is set to 1.
5663
5664 =cut
5665 */
5666
5667 SV *
5668 Perl_newSVnv(pTHX_ NV n)
5669 {
5670     register SV *sv;
5671
5672     new_SV(sv);
5673     sv_setnv(sv,n);
5674     return sv;
5675 }
5676
5677 /*
5678 =for apidoc newSViv
5679
5680 Creates a new SV and copies an integer into it.  The reference count for the
5681 SV is set to 1.
5682
5683 =cut
5684 */
5685
5686 SV *
5687 Perl_newSViv(pTHX_ IV i)
5688 {
5689     register SV *sv;
5690
5691     new_SV(sv);
5692     sv_setiv(sv,i);
5693     return sv;
5694 }
5695
5696 /*
5697 =for apidoc newSVuv
5698
5699 Creates a new SV and copies an unsigned integer into it.
5700 The reference count for the SV is set to 1.
5701
5702 =cut
5703 */
5704
5705 SV *
5706 Perl_newSVuv(pTHX_ UV u)
5707 {
5708     register SV *sv;
5709
5710     new_SV(sv);
5711     sv_setuv(sv,u);
5712     return sv;
5713 }
5714
5715 /*
5716 =for apidoc newRV_noinc
5717
5718 Creates an RV wrapper for an SV.  The reference count for the original
5719 SV is B<not> incremented.
5720
5721 =cut
5722 */
5723
5724 SV *
5725 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5726 {
5727     register SV *sv;
5728
5729     new_SV(sv);
5730     sv_upgrade(sv, SVt_RV);
5731     SvTEMP_off(tmpRef);
5732     SvRV(sv) = tmpRef;
5733     SvROK_on(sv);
5734     return sv;
5735 }
5736
5737 /* newRV_inc is #defined to newRV in sv.h */
5738 SV *
5739 Perl_newRV(pTHX_ SV *tmpRef)
5740 {
5741     return newRV_noinc(SvREFCNT_inc(tmpRef));
5742 }
5743
5744 /*
5745 =for apidoc newSVsv
5746
5747 Creates a new SV which is an exact duplicate of the original SV.
5748
5749 =cut
5750 */
5751
5752 /* make an exact duplicate of old */
5753
5754 SV *
5755 Perl_newSVsv(pTHX_ register SV *old)
5756 {
5757     register SV *sv;
5758
5759     if (!old)
5760         return Nullsv;
5761     if (SvTYPE(old) == SVTYPEMASK) {
5762         if (ckWARN_d(WARN_INTERNAL))
5763             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5764         return Nullsv;
5765     }
5766     new_SV(sv);
5767     if (SvTEMP(old)) {
5768         SvTEMP_off(old);
5769         sv_setsv(sv,old);
5770         SvTEMP_on(old);
5771     }
5772     else
5773         sv_setsv(sv,old);
5774     return sv;
5775 }
5776
5777 void
5778 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5779 {
5780     register HE *entry;
5781     register GV *gv;
5782     register SV *sv;
5783     register I32 i;
5784     register PMOP *pm;
5785     register I32 max;
5786     char todo[PERL_UCHAR_MAX+1];
5787
5788     if (!stash)
5789         return;
5790
5791     if (!*s) {          /* reset ?? searches */
5792         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5793             pm->op_pmdynflags &= ~PMdf_USED;
5794         }
5795         return;
5796     }
5797
5798     /* reset variables */
5799
5800     if (!HvARRAY(stash))
5801         return;
5802
5803     Zero(todo, 256, char);
5804     while (*s) {
5805         i = (unsigned char)*s;
5806         if (s[1] == '-') {
5807             s += 2;
5808         }
5809         max = (unsigned char)*s++;
5810         for ( ; i <= max; i++) {
5811             todo[i] = 1;
5812         }
5813         for (i = 0; i <= (I32) HvMAX(stash); i++) {
5814             for (entry = HvARRAY(stash)[i];
5815                  entry;
5816                  entry = HeNEXT(entry))
5817             {
5818                 if (!todo[(U8)*HeKEY(entry)])
5819                     continue;
5820                 gv = (GV*)HeVAL(entry);
5821                 sv = GvSV(gv);
5822                 if (SvTHINKFIRST(sv)) {
5823                     if (!SvREADONLY(sv) && SvROK(sv))
5824                         sv_unref(sv);
5825                     continue;
5826                 }
5827                 (void)SvOK_off(sv);
5828                 if (SvTYPE(sv) >= SVt_PV) {
5829                     SvCUR_set(sv, 0);
5830                     if (SvPVX(sv) != Nullch)
5831                         *SvPVX(sv) = '\0';
5832                     SvTAINT(sv);
5833                 }
5834                 if (GvAV(gv)) {
5835                     av_clear(GvAV(gv));
5836                 }
5837                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5838                     hv_clear(GvHV(gv));
5839 #ifdef USE_ENVIRON_ARRAY
5840                     if (gv == PL_envgv)
5841                         environ[0] = Nullch;
5842 #endif
5843                 }
5844             }
5845         }
5846     }
5847 }
5848
5849 IO*
5850 Perl_sv_2io(pTHX_ SV *sv)
5851 {
5852     IO* io;
5853     GV* gv;
5854     STRLEN n_a;
5855
5856     switch (SvTYPE(sv)) {
5857     case SVt_PVIO:
5858         io = (IO*)sv;
5859         break;
5860     case SVt_PVGV:
5861         gv = (GV*)sv;
5862         io = GvIO(gv);
5863         if (!io)
5864             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5865         break;
5866     default:
5867         if (!SvOK(sv))
5868             Perl_croak(aTHX_ PL_no_usym, "filehandle");
5869         if (SvROK(sv))
5870             return sv_2io(SvRV(sv));
5871         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5872         if (gv)
5873             io = GvIO(gv);
5874         else
5875             io = 0;
5876         if (!io)
5877             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5878         break;
5879     }
5880     return io;
5881 }
5882
5883 CV *
5884 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5885 {
5886     GV *gv;
5887     CV *cv;
5888     STRLEN n_a;
5889
5890     if (!sv)
5891         return *gvp = Nullgv, Nullcv;
5892     switch (SvTYPE(sv)) {
5893     case SVt_PVCV:
5894         *st = CvSTASH(sv);
5895         *gvp = Nullgv;
5896         return (CV*)sv;
5897     case SVt_PVHV:
5898     case SVt_PVAV:
5899         *gvp = Nullgv;
5900         return Nullcv;
5901     case SVt_PVGV:
5902         gv = (GV*)sv;
5903         *gvp = gv;
5904         *st = GvESTASH(gv);
5905         goto fix_gv;
5906
5907     default:
5908         if (SvGMAGICAL(sv))
5909             mg_get(sv);
5910         if (SvROK(sv)) {
5911             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
5912             tryAMAGICunDEREF(to_cv);
5913
5914             sv = SvRV(sv);
5915             if (SvTYPE(sv) == SVt_PVCV) {
5916                 cv = (CV*)sv;
5917                 *gvp = Nullgv;
5918                 *st = CvSTASH(cv);
5919                 return cv;
5920             }
5921             else if(isGV(sv))
5922                 gv = (GV*)sv;
5923             else
5924                 Perl_croak(aTHX_ "Not a subroutine reference");
5925         }
5926         else if (isGV(sv))
5927             gv = (GV*)sv;
5928         else
5929             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5930         *gvp = gv;
5931         if (!gv)
5932             return Nullcv;
5933         *st = GvESTASH(gv);
5934     fix_gv:
5935         if (lref && !GvCVu(gv)) {
5936             SV *tmpsv;
5937             ENTER;
5938             tmpsv = NEWSV(704,0);
5939             gv_efullname3(tmpsv, gv, Nullch);
5940             /* XXX this is probably not what they think they're getting.
5941              * It has the same effect as "sub name;", i.e. just a forward
5942              * declaration! */
5943             newSUB(start_subparse(FALSE, 0),
5944                    newSVOP(OP_CONST, 0, tmpsv),
5945                    Nullop,
5946                    Nullop);
5947             LEAVE;
5948             if (!GvCVu(gv))
5949                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5950         }
5951         return GvCVu(gv);
5952     }
5953 }
5954
5955 /*
5956 =for apidoc sv_true
5957
5958 Returns true if the SV has a true value by Perl's rules.
5959
5960 =cut
5961 */
5962
5963 I32
5964 Perl_sv_true(pTHX_ register SV *sv)
5965 {
5966     if (!sv)
5967         return 0;
5968     if (SvPOK(sv)) {
5969         register XPV* tXpv;
5970         if ((tXpv = (XPV*)SvANY(sv)) &&
5971                 (tXpv->xpv_cur > 1 ||
5972                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5973             return 1;
5974         else
5975             return 0;
5976     }
5977     else {
5978         if (SvIOK(sv))
5979             return SvIVX(sv) != 0;
5980         else {
5981             if (SvNOK(sv))
5982                 return SvNVX(sv) != 0.0;
5983             else
5984                 return sv_2bool(sv);
5985         }
5986     }
5987 }
5988
5989 IV
5990 Perl_sv_iv(pTHX_ register SV *sv)
5991 {
5992     if (SvIOK(sv)) {
5993         if (SvIsUV(sv))
5994             return (IV)SvUVX(sv);
5995         return SvIVX(sv);
5996     }
5997     return sv_2iv(sv);
5998 }
5999
6000 UV
6001 Perl_sv_uv(pTHX_ register SV *sv)
6002 {
6003     if (SvIOK(sv)) {
6004         if (SvIsUV(sv))
6005             return SvUVX(sv);
6006         return (UV)SvIVX(sv);
6007     }
6008     return sv_2uv(sv);
6009 }
6010
6011 NV
6012 Perl_sv_nv(pTHX_ register SV *sv)
6013 {
6014     if (SvNOK(sv))
6015         return SvNVX(sv);
6016     return sv_2nv(sv);
6017 }
6018
6019 char *
6020 Perl_sv_pv(pTHX_ SV *sv)
6021 {
6022     STRLEN n_a;
6023
6024     if (SvPOK(sv))
6025         return SvPVX(sv);
6026
6027     return sv_2pv(sv, &n_a);
6028 }
6029
6030 char *
6031 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6032 {
6033     if (SvPOK(sv)) {
6034         *lp = SvCUR(sv);
6035         return SvPVX(sv);
6036     }
6037     return sv_2pv(sv, lp);
6038 }
6039
6040 /*
6041 =for apidoc sv_pvn_force
6042
6043 Get a sensible string out of the SV somehow.
6044
6045 =cut
6046 */
6047
6048 char *
6049 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6050 {
6051     char *s;
6052
6053     if (SvTHINKFIRST(sv) && !SvROK(sv))
6054         sv_force_normal(sv);
6055
6056     if (SvPOK(sv)) {
6057         *lp = SvCUR(sv);
6058     }
6059     else {
6060         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6061             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6062                 PL_op_name[PL_op->op_type]);
6063         }
6064         else
6065             s = sv_2pv(sv, lp);
6066         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
6067             STRLEN len = *lp;
6068
6069             if (SvROK(sv))
6070                 sv_unref(sv);
6071             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
6072             SvGROW(sv, len + 1);
6073             Move(s,SvPVX(sv),len,char);
6074             SvCUR_set(sv, len);
6075             *SvEND(sv) = '\0';
6076         }
6077         if (!SvPOK(sv)) {
6078             SvPOK_on(sv);               /* validate pointer */
6079             SvTAINT(sv);
6080             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6081                                   PTR2UV(sv),SvPVX(sv)));
6082         }
6083     }
6084     return SvPVX(sv);
6085 }
6086
6087 char *
6088 Perl_sv_pvbyte(pTHX_ SV *sv)
6089 {
6090     return sv_pv(sv);
6091 }
6092
6093 char *
6094 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6095 {
6096     return sv_pvn(sv,lp);
6097 }
6098
6099 char *
6100 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6101 {
6102     return sv_pvn_force(sv,lp);
6103 }
6104
6105 char *
6106 Perl_sv_pvutf8(pTHX_ SV *sv)
6107 {
6108     sv_utf8_upgrade(sv);
6109     return sv_pv(sv);
6110 }
6111
6112 char *
6113 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6114 {
6115     sv_utf8_upgrade(sv);
6116     return sv_pvn(sv,lp);
6117 }
6118
6119 /*
6120 =for apidoc sv_pvutf8n_force
6121
6122 Get a sensible UTF8-encoded string out of the SV somehow. See
6123 L</sv_pvn_force>.
6124
6125 =cut
6126 */
6127
6128 char *
6129 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6130 {
6131     sv_utf8_upgrade(sv);
6132     return sv_pvn_force(sv,lp);
6133 }
6134
6135 /*
6136 =for apidoc sv_reftype
6137
6138 Returns a string describing what the SV is a reference to.
6139
6140 =cut
6141 */
6142
6143 char *
6144 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6145 {
6146     if (ob && SvOBJECT(sv))
6147         return HvNAME(SvSTASH(sv));
6148     else {
6149         switch (SvTYPE(sv)) {
6150         case SVt_NULL:
6151         case SVt_IV:
6152         case SVt_NV:
6153         case SVt_RV:
6154         case SVt_PV:
6155         case SVt_PVIV:
6156         case SVt_PVNV:
6157         case SVt_PVMG:
6158         case SVt_PVBM:
6159                                 if (SvROK(sv))
6160                                     return "REF";
6161                                 else
6162                                     return "SCALAR";
6163         case SVt_PVLV:          return "LVALUE";
6164         case SVt_PVAV:          return "ARRAY";
6165         case SVt_PVHV:          return "HASH";
6166         case SVt_PVCV:          return "CODE";
6167         case SVt_PVGV:          return "GLOB";
6168         case SVt_PVFM:          return "FORMAT";
6169         case SVt_PVIO:          return "IO";
6170         default:                return "UNKNOWN";
6171         }
6172     }
6173 }
6174
6175 /*
6176 =for apidoc sv_isobject
6177
6178 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6179 object.  If the SV is not an RV, or if the object is not blessed, then this
6180 will return false.
6181
6182 =cut
6183 */
6184
6185 int
6186 Perl_sv_isobject(pTHX_ SV *sv)
6187 {
6188     if (!sv)
6189         return 0;
6190     if (SvGMAGICAL(sv))
6191         mg_get(sv);
6192     if (!SvROK(sv))
6193         return 0;
6194     sv = (SV*)SvRV(sv);
6195     if (!SvOBJECT(sv))
6196         return 0;
6197     return 1;
6198 }
6199
6200 /*
6201 =for apidoc sv_isa
6202
6203 Returns a boolean indicating whether the SV is blessed into the specified
6204 class.  This does not check for subtypes; use C<sv_derived_from> to verify
6205 an inheritance relationship.
6206
6207 =cut
6208 */
6209
6210 int
6211 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6212 {
6213     if (!sv)
6214         return 0;
6215     if (SvGMAGICAL(sv))
6216         mg_get(sv);
6217     if (!SvROK(sv))
6218         return 0;
6219     sv = (SV*)SvRV(sv);
6220     if (!SvOBJECT(sv))
6221         return 0;
6222
6223     return strEQ(HvNAME(SvSTASH(sv)), name);
6224 }
6225
6226 /*
6227 =for apidoc newSVrv
6228
6229 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
6230 it will be upgraded to one.  If C<classname> is non-null then the new SV will
6231 be blessed in the specified package.  The new SV is returned and its
6232 reference count is 1.
6233
6234 =cut
6235 */
6236
6237 SV*
6238 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6239 {
6240     SV *sv;
6241
6242     new_SV(sv);
6243
6244     SV_CHECK_THINKFIRST(rv);
6245     SvAMAGIC_off(rv);
6246
6247     if (SvTYPE(rv) >= SVt_PVMG) {
6248         U32 refcnt = SvREFCNT(rv);
6249         SvREFCNT(rv) = 0;
6250         sv_clear(rv);
6251         SvFLAGS(rv) = 0;
6252         SvREFCNT(rv) = refcnt;
6253     }
6254
6255     if (SvTYPE(rv) < SVt_RV)
6256         sv_upgrade(rv, SVt_RV);
6257     else if (SvTYPE(rv) > SVt_RV) {
6258         (void)SvOOK_off(rv);
6259         if (SvPVX(rv) && SvLEN(rv))
6260             Safefree(SvPVX(rv));
6261         SvCUR_set(rv, 0);
6262         SvLEN_set(rv, 0);
6263     }
6264
6265     (void)SvOK_off(rv);
6266     SvRV(rv) = sv;
6267     SvROK_on(rv);
6268
6269     if (classname) {
6270         HV* stash = gv_stashpv(classname, TRUE);
6271         (void)sv_bless(rv, stash);
6272     }
6273     return sv;
6274 }
6275
6276 /*
6277 =for apidoc sv_setref_pv
6278
6279 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
6280 argument will be upgraded to an RV.  That RV will be modified to point to
6281 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6282 into the SV.  The C<classname> argument indicates the package for the
6283 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
6284 will be returned and will have a reference count of 1.
6285
6286 Do not use with other Perl types such as HV, AV, SV, CV, because those
6287 objects will become corrupted by the pointer copy process.
6288
6289 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6290
6291 =cut
6292 */
6293
6294 SV*
6295 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6296 {
6297     if (!pv) {
6298         sv_setsv(rv, &PL_sv_undef);
6299         SvSETMAGIC(rv);
6300     }
6301     else
6302         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6303     return rv;
6304 }
6305
6306 /*
6307 =for apidoc sv_setref_iv
6308
6309 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
6310 argument will be upgraded to an RV.  That RV will be modified to point to
6311 the new SV.  The C<classname> argument indicates the package for the
6312 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
6313 will be returned and will have a reference count of 1.
6314
6315 =cut
6316 */
6317
6318 SV*
6319 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6320 {
6321     sv_setiv(newSVrv(rv,classname), iv);
6322     return rv;
6323 }
6324
6325 /*
6326 =for apidoc sv_setref_nv
6327
6328 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
6329 argument will be upgraded to an RV.  That RV will be modified to point to
6330 the new SV.  The C<classname> argument indicates the package for the
6331 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
6332 will be returned and will have a reference count of 1.
6333
6334 =cut
6335 */
6336
6337 SV*
6338 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6339 {
6340     sv_setnv(newSVrv(rv,classname), nv);
6341     return rv;
6342 }
6343
6344 /*
6345 =for apidoc sv_setref_pvn
6346
6347 Copies a string into a new SV, optionally blessing the SV.  The length of the
6348 string must be specified with C<n>.  The C<rv> argument will be upgraded to
6349 an RV.  That RV will be modified to point to the new SV.  The C<classname>
6350 argument indicates the package for the blessing.  Set C<classname> to
6351 C<Nullch> to avoid the blessing.  The new SV will be returned and will have
6352 a reference count of 1.
6353
6354 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6355
6356 =cut
6357 */
6358
6359 SV*
6360 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6361 {
6362     sv_setpvn(newSVrv(rv,classname), pv, n);
6363     return rv;
6364 }
6365
6366 /*
6367 =for apidoc sv_bless
6368
6369 Blesses an SV into a specified package.  The SV must be an RV.  The package
6370 must be designated by its stash (see C<gv_stashpv()>).  The reference count
6371 of the SV is unaffected.
6372
6373 =cut
6374 */
6375
6376 SV*
6377 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6378 {
6379     SV *tmpRef;
6380     if (!SvROK(sv))
6381         Perl_croak(aTHX_ "Can't bless non-reference value");
6382     tmpRef = SvRV(sv);
6383     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6384         if (SvREADONLY(tmpRef))
6385             Perl_croak(aTHX_ PL_no_modify);
6386         if (SvOBJECT(tmpRef)) {
6387             if (SvTYPE(tmpRef) != SVt_PVIO)
6388                 --PL_sv_objcount;
6389             SvREFCNT_dec(SvSTASH(tmpRef));
6390         }
6391     }
6392     SvOBJECT_on(tmpRef);
6393     if (SvTYPE(tmpRef) != SVt_PVIO)
6394         ++PL_sv_objcount;
6395     (void)SvUPGRADE(tmpRef, SVt_PVMG);
6396     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6397
6398     if (Gv_AMG(stash))
6399         SvAMAGIC_on(sv);
6400     else
6401         SvAMAGIC_off(sv);
6402
6403     return sv;
6404 }
6405
6406 STATIC void
6407 S_sv_unglob(pTHX_ SV *sv)
6408 {
6409     void *xpvmg;
6410
6411     assert(SvTYPE(sv) == SVt_PVGV);
6412     SvFAKE_off(sv);
6413     if (GvGP(sv))
6414         gp_free((GV*)sv);
6415     if (GvSTASH(sv)) {
6416         SvREFCNT_dec(GvSTASH(sv));
6417         GvSTASH(sv) = Nullhv;
6418     }
6419     sv_unmagic(sv, '*');
6420     Safefree(GvNAME(sv));
6421     GvMULTI_off(sv);
6422
6423     /* need to keep SvANY(sv) in the right arena */
6424     xpvmg = new_XPVMG();
6425     StructCopy(SvANY(sv), xpvmg, XPVMG);
6426     del_XPVGV(SvANY(sv));
6427     SvANY(sv) = xpvmg;
6428
6429     SvFLAGS(sv) &= ~SVTYPEMASK;
6430     SvFLAGS(sv) |= SVt_PVMG;
6431 }
6432
6433 /*
6434 =for apidoc sv_unref_flags
6435
6436 Unsets the RV status of the SV, and decrements the reference count of
6437 whatever was being referenced by the RV.  This can almost be thought of
6438 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
6439 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6440 (otherwise the decrementing is conditional on the reference count being
6441 different from one or the reference being a readonly SV).
6442 See C<SvROK_off>.
6443
6444 =cut
6445 */
6446
6447 void
6448 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6449 {
6450     SV* rv = SvRV(sv);
6451
6452     if (SvWEAKREF(sv)) {
6453         sv_del_backref(sv);
6454         SvWEAKREF_off(sv);
6455         SvRV(sv) = 0;
6456         return;
6457     }
6458     SvRV(sv) = 0;
6459     SvROK_off(sv);
6460     if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6461         SvREFCNT_dec(rv);
6462     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6463         sv_2mortal(rv);         /* Schedule for freeing later */
6464 }
6465
6466 /*
6467 =for apidoc sv_unref
6468
6469 Unsets the RV status of the SV, and decrements the reference count of
6470 whatever was being referenced by the RV.  This can almost be thought of
6471 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
6472 being zero.  See C<SvROK_off>.
6473
6474 =cut
6475 */
6476
6477 void
6478 Perl_sv_unref(pTHX_ SV *sv)
6479 {
6480     sv_unref_flags(sv, 0);
6481 }
6482
6483 void
6484 Perl_sv_taint(pTHX_ SV *sv)
6485 {
6486     sv_magic((sv), Nullsv, 't', Nullch, 0);
6487 }
6488
6489 void
6490 Perl_sv_untaint(pTHX_ SV *sv)
6491 {
6492     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6493         MAGIC *mg = mg_find(sv, 't');
6494         if (mg)
6495             mg->mg_len &= ~1;
6496     }
6497 }
6498
6499 bool
6500 Perl_sv_tainted(pTHX_ SV *sv)
6501 {
6502     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6503         MAGIC *mg = mg_find(sv, 't');
6504         if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6505             return TRUE;
6506     }
6507     return FALSE;
6508 }
6509
6510 /*
6511 =for apidoc sv_setpviv
6512
6513 Copies an integer into the given SV, also updating its string value.
6514 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
6515
6516 =cut
6517 */
6518
6519 void
6520 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6521 {
6522     char buf[TYPE_CHARS(UV)];
6523     char *ebuf;
6524     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6525
6526     sv_setpvn(sv, ptr, ebuf - ptr);
6527 }
6528
6529
6530 /*
6531 =for apidoc sv_setpviv_mg
6532
6533 Like C<sv_setpviv>, but also handles 'set' magic.
6534
6535 =cut
6536 */
6537
6538 void
6539 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6540 {
6541     char buf[TYPE_CHARS(UV)];
6542     char *ebuf;
6543     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6544
6545     sv_setpvn(sv, ptr, ebuf - ptr);
6546     SvSETMAGIC(sv);
6547 }
6548
6549 #if defined(PERL_IMPLICIT_CONTEXT)
6550 void
6551 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6552 {
6553     dTHX;
6554     va_list args;
6555     va_start(args, pat);
6556     sv_vsetpvf(sv, pat, &args);
6557     va_end(args);
6558 }
6559
6560
6561 void
6562 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6563 {
6564     dTHX;
6565     va_list args;
6566     va_start(args, pat);
6567     sv_vsetpvf_mg(sv, pat, &args);
6568     va_end(args);
6569 }
6570 #endif
6571
6572 /*
6573 =for apidoc sv_setpvf
6574
6575 Processes its arguments like C<sprintf> and sets an SV to the formatted
6576 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
6577
6578 =cut
6579 */
6580
6581 void
6582 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6583 {
6584     va_list args;
6585     va_start(args, pat);
6586     sv_vsetpvf(sv, pat, &args);
6587     va_end(args);
6588 }
6589
6590 void
6591 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6592 {
6593     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6594 }
6595
6596 /*
6597 =for apidoc sv_setpvf_mg
6598
6599 Like C<sv_setpvf>, but also handles 'set' magic.
6600
6601 =cut
6602 */
6603
6604 void
6605 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6606 {
6607     va_list args;
6608     va_start(args, pat);
6609     sv_vsetpvf_mg(sv, pat, &args);
6610     va_end(args);
6611 }
6612
6613 void
6614 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6615 {
6616     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6617     SvSETMAGIC(sv);
6618 }
6619
6620 #if defined(PERL_IMPLICIT_CONTEXT)
6621 void
6622 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6623 {
6624     dTHX;
6625     va_list args;
6626     va_start(args, pat);
6627     sv_vcatpvf(sv, pat, &args);
6628     va_end(args);
6629 }
6630
6631 void
6632 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6633 {
6634     dTHX;
6635     va_list args;
6636     va_start(args, pat);
6637     sv_vcatpvf_mg(sv, pat, &args);
6638     va_end(args);
6639 }
6640 #endif
6641
6642 /*
6643 =for apidoc sv_catpvf
6644
6645 Processes its arguments like C<sprintf> and appends the formatted output
6646 to an SV.  Handles 'get' magic, but not 'set' magic.  C<SvSETMAGIC()> must
6647 typically be called after calling this function to handle 'set' magic.
6648
6649 =cut
6650 */
6651
6652 void
6653 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6654 {
6655     va_list args;
6656     va_start(args, pat);
6657     sv_vcatpvf(sv, pat, &args);
6658     va_end(args);
6659 }
6660
6661 void
6662 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6663 {
6664     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6665 }
6666
6667 /*
6668 =for apidoc sv_catpvf_mg
6669
6670 Like C<sv_catpvf>, but also handles 'set' magic.
6671
6672 =cut
6673 */
6674
6675 void
6676 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6677 {
6678     va_list args;
6679     va_start(args, pat);
6680     sv_vcatpvf_mg(sv, pat, &args);
6681     va_end(args);
6682 }
6683
6684 void
6685 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6686 {
6687     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6688     SvSETMAGIC(sv);
6689 }
6690
6691 /*
6692 =for apidoc sv_vsetpvfn
6693
6694 Works like C<vcatpvfn> but copies the text into the SV instead of
6695 appending it.
6696
6697 =cut
6698 */
6699
6700 void
6701 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6702 {
6703     sv_setpvn(sv, "", 0);
6704     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6705 }
6706
6707 /*
6708 =for apidoc sv_vcatpvfn
6709
6710 Processes its arguments like C<vsprintf> and appends the formatted output
6711 to an SV.  Uses an array of SVs if the C style variable argument list is
6712 missing (NULL).  When running with taint checks enabled, indicates via
6713 C<maybe_tainted> if results are untrustworthy (often due to the use of
6714 locales).
6715
6716 =cut
6717 */
6718
6719 void
6720 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6721 {
6722     char *p;
6723     char *q;
6724     char *patend;
6725     STRLEN origlen;
6726     I32 svix = 0;
6727     static char nullstr[] = "(null)";
6728     SV *argsv;
6729
6730     /* no matter what, this is a string now */
6731     (void)SvPV_force(sv, origlen);
6732
6733     /* special-case "", "%s", and "%_" */
6734     if (patlen == 0)
6735         return;
6736     if (patlen == 2 && pat[0] == '%') {
6737         switch (pat[1]) {
6738         case 's':
6739             if (args) {
6740                 char *s = va_arg(*args, char*);
6741                 sv_catpv(sv, s ? s : nullstr);
6742             }
6743             else if (svix < svmax) {
6744                 sv_catsv(sv, *svargs);
6745                 if (DO_UTF8(*svargs))
6746                     SvUTF8_on(sv);
6747             }
6748             return;
6749         case '_':
6750             if (args) {
6751                 argsv = va_arg(*args, SV*);
6752                 sv_catsv(sv, argsv);
6753                 if (DO_UTF8(argsv))
6754                     SvUTF8_on(sv);
6755                 return;
6756             }
6757             /* See comment on '_' below */
6758             break;
6759         }
6760     }
6761
6762     patend = (char*)pat + patlen;
6763     for (p = (char*)pat; p < patend; p = q) {
6764         bool alt = FALSE;
6765         bool left = FALSE;
6766         bool vectorize = FALSE;
6767         bool utf = FALSE;
6768         char fill = ' ';
6769         char plus = 0;
6770         char intsize = 0;
6771         STRLEN width = 0;
6772         STRLEN zeros = 0;
6773         bool has_precis = FALSE;
6774         STRLEN precis = 0;
6775         bool is_utf = FALSE;
6776
6777         char esignbuf[4];
6778         U8 utf8buf[UTF8_MAXLEN+1];
6779         STRLEN esignlen = 0;
6780
6781         char *eptr = Nullch;
6782         STRLEN elen = 0;
6783         /* Times 4: a decimal digit takes more than 3 binary digits.
6784          * NV_DIG: mantissa takes than many decimal digits.
6785          * Plus 32: Playing safe. */
6786         char ebuf[IV_DIG * 4 + NV_DIG + 32];
6787         /* large enough for "%#.#f" --chip */
6788         /* what about long double NVs? --jhi */
6789
6790         SV *vecsv;
6791         U8 *vecstr = Null(U8*);
6792         STRLEN veclen = 0;
6793         char c;
6794         int i;
6795         unsigned base;
6796         IV iv;
6797         UV uv;
6798         NV nv;
6799         STRLEN have;
6800         STRLEN need;
6801         STRLEN gap;
6802         char *dotstr = ".";
6803         STRLEN dotstrlen = 1;
6804         I32 epix = 0; /* explicit parameter index */
6805         I32 ewix = 0; /* explicit width index */
6806         bool asterisk = FALSE;
6807
6808         for (q = p; q < patend && *q != '%'; ++q) ;
6809         if (q > p) {
6810             sv_catpvn(sv, p, q - p);
6811             p = q;
6812         }
6813         if (q++ >= patend)
6814             break;
6815
6816         /* FLAGS */
6817
6818         while (*q) {
6819             switch (*q) {
6820             case ' ':
6821             case '+':
6822                 plus = *q++;
6823                 continue;
6824
6825             case '-':
6826                 left = TRUE;
6827                 q++;
6828                 continue;
6829
6830             case '0':
6831                 fill = *q++;
6832                 continue;
6833
6834             case '#':
6835                 alt = TRUE;
6836                 q++;
6837                 continue;
6838
6839             case '*':                   /* printf("%*vX",":",$ipv6addr) */
6840                 if (q[1] != 'v')
6841                     break;
6842                 q++;
6843                 if (args)
6844                     vecsv = va_arg(*args, SV*);
6845                 else if (svix < svmax)
6846                     vecsv = svargs[svix++];
6847                 else
6848                     continue;
6849                 dotstr = SvPVx(vecsv,dotstrlen);
6850                 if (DO_UTF8(vecsv))
6851                     is_utf = TRUE;
6852                 /* FALL THROUGH */
6853
6854             case 'v':
6855                 vectorize = TRUE;
6856                 q++;
6857                 continue;
6858
6859             default:
6860                 break;
6861             }
6862             break;
6863         }
6864
6865         /* WIDTH */
6866
6867     scanwidth:
6868
6869         if (*q == '*') {
6870             if (asterisk)
6871                 goto unknown;
6872             asterisk = TRUE;
6873             q++;
6874         }
6875
6876         switch (*q) {
6877         case '1': case '2': case '3':
6878         case '4': case '5': case '6':
6879         case '7': case '8': case '9':
6880             width = 0;
6881             while (isDIGIT(*q))
6882                 width = width * 10 + (*q++ - '0');
6883             if (*q == '$') {
6884                 if (asterisk && ewix == 0) {
6885                     ewix  = width;
6886                     width = 0;
6887                     q++;
6888                     goto scanwidth;
6889                 } else if (epix == 0) {
6890                     epix  = width;
6891                     width = 0;
6892                     q++;
6893                     goto scanwidth;
6894                 } else
6895                     goto unknown;
6896             }
6897         }
6898
6899         if (asterisk) {
6900             if (args)
6901                 i = va_arg(*args, int);
6902             else
6903                 i = (ewix ? ewix <= svmax : svix < svmax) ?
6904                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6905             left |= (i < 0);
6906             width = (i < 0) ? -i : i;
6907         }
6908
6909         /* PRECISION */
6910
6911         if (*q == '.') {
6912             q++;
6913             if (*q == '*') {
6914                 if (args)
6915                     i = va_arg(*args, int);
6916                 else
6917                     i = (ewix ? ewix <= svmax : svix < svmax)
6918                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6919                 precis = (i < 0) ? 0 : i;
6920                 q++;
6921             }
6922             else {
6923                 precis = 0;
6924                 while (isDIGIT(*q))
6925                     precis = precis * 10 + (*q++ - '0');
6926             }
6927             has_precis = TRUE;
6928         }
6929
6930         if (vectorize) {
6931             if (args) {
6932                 vecsv = va_arg(*args, SV*);
6933                 vecstr = (U8*)SvPVx(vecsv,veclen);
6934                 utf = DO_UTF8(vecsv);
6935             }
6936             else if (epix ? epix <= svmax : svix < svmax) {
6937                 vecsv = svargs[epix ? epix-1 : svix++];
6938                 vecstr = (U8*)SvPVx(vecsv,veclen);
6939                 utf = DO_UTF8(vecsv);
6940             }
6941             else {
6942                 vecstr = (U8*)"";
6943                 veclen = 0;
6944             }
6945         }
6946
6947         /* SIZE */
6948
6949         switch (*q) {
6950 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6951         case 'L':                       /* Ld */
6952             /* FALL THROUGH */
6953 #endif
6954 #ifdef HAS_QUAD
6955         case 'q':                       /* qd */
6956             intsize = 'q';
6957             q++;
6958             break;
6959 #endif
6960         case 'l':
6961 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6962              if (*(q + 1) == 'l') {     /* lld, llf */
6963                 intsize = 'q';
6964                 q += 2;
6965                 break;
6966              }
6967 #endif
6968             /* FALL THROUGH */
6969         case 'h':
6970             /* FALL THROUGH */
6971         case 'V':
6972             intsize = *q++;
6973             break;
6974         }
6975
6976         /* CONVERSION */
6977
6978         switch (c = *q++) {
6979
6980             /* STRINGS */
6981
6982         case '%':
6983             eptr = q - 1;
6984             elen = 1;
6985             goto string;
6986
6987         case 'c':
6988             if (args)
6989                 uv = va_arg(*args, int);
6990             else
6991                 uv = (epix ? epix <= svmax : svix < svmax) ?
6992                     SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6993             if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6994                 eptr = (char*)utf8buf;
6995                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6996                 is_utf = TRUE;
6997             }
6998             else {
6999                 c = (char)uv;
7000                 eptr = &c;
7001                 elen = 1;
7002             }
7003             goto string;
7004
7005         case 's':
7006             if (args) {
7007                 eptr = va_arg(*args, char*);
7008                 if (eptr)
7009 #ifdef MACOS_TRADITIONAL
7010                   /* On MacOS, %#s format is used for Pascal strings */
7011                   if (alt)
7012                     elen = *eptr++;
7013                   else
7014 #endif
7015                     elen = strlen(eptr);
7016                 else {
7017                     eptr = nullstr;
7018                     elen = sizeof nullstr - 1;
7019                 }
7020             }
7021             else if (epix ? epix <= svmax : svix < svmax) {
7022                 argsv = svargs[epix ? epix-1 : svix++];
7023                 eptr = SvPVx(argsv, elen);
7024                 if (DO_UTF8(argsv)) {
7025                     if (has_precis && precis < elen) {
7026                         I32 p = precis;
7027                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7028                         precis = p;
7029                     }
7030                     if (width) { /* fudge width (can't fudge elen) */
7031                         width += elen - sv_len_utf8(argsv);
7032                     }
7033                     is_utf = TRUE;
7034                 }
7035             }
7036             goto string;
7037
7038         case '_':
7039             /*
7040              * The "%_" hack might have to be changed someday,
7041              * if ISO or ANSI decide to use '_' for something.
7042              * So we keep it hidden from users' code.
7043              */
7044             if (!args)
7045                 goto unknown;
7046             argsv = va_arg(*args,SV*);
7047             eptr = SvPVx(argsv, elen);
7048             if (DO_UTF8(argsv))
7049                 is_utf = TRUE;
7050
7051         string:
7052             vectorize = FALSE;
7053             if (has_precis && elen > precis)
7054                 elen = precis;
7055             break;
7056
7057             /* INTEGERS */
7058
7059         case 'p':
7060             if (alt)
7061                 goto unknown;
7062             if (args)
7063                 uv = PTR2UV(va_arg(*args, void*));
7064             else
7065                 uv = (epix ? epix <= svmax : svix < svmax) ?
7066                     PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
7067             base = 16;
7068             goto integer;
7069
7070         case 'D':
7071 #ifdef IV_IS_QUAD
7072             intsize = 'q';
7073 #else
7074             intsize = 'l';
7075 #endif
7076             /* FALL THROUGH */
7077         case 'd':
7078         case 'i':
7079             if (vectorize) {
7080                 STRLEN ulen;
7081                 if (!veclen) {
7082                     vectorize = FALSE;
7083                     break;
7084                 }
7085                 if (utf)
7086                     iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7087                 else {
7088                     iv = *vecstr;
7089                     ulen = 1;
7090                 }
7091                 vecstr += ulen;
7092                 veclen -= ulen;
7093             }
7094             else if (args) {
7095                 switch (intsize) {
7096                 case 'h':       iv = (short)va_arg(*args, int); break;
7097                 default:        iv = va_arg(*args, int); break;
7098                 case 'l':       iv = va_arg(*args, long); break;
7099                 case 'V':       iv = va_arg(*args, IV); break;
7100 #ifdef HAS_QUAD
7101                 case 'q':       iv = va_arg(*args, Quad_t); break;
7102 #endif
7103                 }
7104             }
7105             else {
7106                 iv = (epix ? epix <= svmax : svix < svmax) ?
7107                     SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
7108                 switch (intsize) {
7109                 case 'h':       iv = (short)iv; break;
7110                 default:        break;
7111                 case 'l':       iv = (long)iv; break;
7112                 case 'V':       break;
7113 #ifdef HAS_QUAD
7114                 case 'q':       iv = (Quad_t)iv; break;
7115 #endif
7116                 }
7117             }
7118             if (iv >= 0) {
7119                 uv = iv;
7120                 if (plus)
7121                     esignbuf[esignlen++] = plus;
7122             }
7123             else {
7124                 uv = -iv;
7125                 esignbuf[esignlen++] = '-';
7126             }
7127             base = 10;
7128             goto integer;
7129
7130         case 'U':
7131 #ifdef IV_IS_QUAD
7132             intsize = 'q';
7133 #else
7134             intsize = 'l';
7135 #endif
7136             /* FALL THROUGH */
7137         case 'u':
7138             base = 10;
7139             goto uns_integer;
7140
7141         case 'b':
7142             base = 2;
7143             goto uns_integer;
7144
7145         case 'O':
7146 #ifdef IV_IS_QUAD
7147             intsize = 'q';
7148 #else
7149             intsize = 'l';
7150 #endif
7151             /* FALL THROUGH */
7152         case 'o':
7153             base = 8;
7154             goto uns_integer;
7155
7156         case 'X':
7157         case 'x':
7158             base = 16;
7159
7160         uns_integer:
7161             if (vectorize) {
7162                 STRLEN ulen;
7163         vector:
7164                 if (!veclen) {
7165                     vectorize = FALSE;
7166                     break;
7167                 }
7168                 if (utf)
7169                     uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7170                 else {
7171                     uv = *vecstr;
7172                     ulen = 1;
7173                 }
7174                 vecstr += ulen;
7175                 veclen -= ulen;
7176             }
7177             else if (args) {
7178                 switch (intsize) {
7179                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
7180                 default:   uv = va_arg(*args, unsigned); break;
7181                 case 'l':  uv = va_arg(*args, unsigned long); break;
7182                 case 'V':  uv = va_arg(*args, UV); break;
7183 #ifdef HAS_QUAD
7184                 case 'q':  uv = va_arg(*args, Quad_t); break;
7185 #endif
7186                 }
7187             }
7188             else {
7189                 uv = (epix ? epix <= svmax : svix < svmax) ?
7190                     SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
7191                 switch (intsize) {
7192                 case 'h':       uv = (unsigned short)uv; break;
7193                 default:        break;
7194                 case 'l':       uv = (unsigned long)uv; break;
7195                 case 'V':       break;
7196 #ifdef HAS_QUAD
7197                 case 'q':       uv = (Quad_t)uv; break;
7198 #endif
7199                 }
7200             }
7201
7202         integer:
7203             eptr = ebuf + sizeof ebuf;
7204             switch (base) {
7205                 unsigned dig;
7206             case 16:
7207                 if (!uv)
7208                     alt = FALSE;
7209                 p = (char*)((c == 'X')
7210                             ? "0123456789ABCDEF" : "0123456789abcdef");
7211                 do {
7212                     dig = uv & 15;
7213                     *--eptr = p[dig];
7214                 } while (uv >>= 4);
7215                 if (alt) {
7216                     esignbuf[esignlen++] = '0';
7217                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
7218                 }
7219                 break;
7220             case 8:
7221                 do {
7222                     dig = uv & 7;
7223                     *--eptr = '0' + dig;
7224                 } while (uv >>= 3);
7225                 if (alt && *eptr != '0')
7226                     *--eptr = '0';
7227                 break;
7228             case 2:
7229                 do {
7230                     dig = uv & 1;
7231                     *--eptr = '0' + dig;
7232                 } while (uv >>= 1);
7233                 if (alt) {
7234                     esignbuf[esignlen++] = '0';
7235                     esignbuf[esignlen++] = 'b';
7236                 }
7237                 break;
7238             default:            /* it had better be ten or less */
7239 #if defined(PERL_Y2KWARN)
7240                 if (ckWARN(WARN_Y2K)) {
7241                     STRLEN n;
7242                     char *s = SvPV(sv,n);
7243                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7244                         && (n == 2 || !isDIGIT(s[n-3])))
7245                     {
7246                         Perl_warner(aTHX_ WARN_Y2K,
7247                                     "Possible Y2K bug: %%%c %s",
7248                                     c, "format string following '19'");
7249                     }
7250                 }
7251 #endif
7252                 do {
7253                     dig = uv % base;
7254                     *--eptr = '0' + dig;
7255                 } while (uv /= base);
7256                 break;
7257             }
7258             elen = (ebuf + sizeof ebuf) - eptr;
7259             if (has_precis) {
7260                 if (precis > elen)
7261                     zeros = precis - elen;
7262                 else if (precis == 0 && elen == 1 && *eptr == '0')
7263                     elen = 0;
7264             }
7265             break;
7266
7267             /* FLOATING POINT */
7268
7269         case 'F':
7270             c = 'f';            /* maybe %F isn't supported here */
7271             /* FALL THROUGH */
7272         case 'e': case 'E':
7273         case 'f':
7274         case 'g': case 'G':
7275
7276             /* This is evil, but floating point is even more evil */
7277
7278             vectorize = FALSE;
7279             if (args)
7280                 nv = va_arg(*args, NV);
7281             else
7282                 nv = (epix ? epix <= svmax : svix < svmax) ?
7283                     SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
7284
7285             need = 0;
7286             if (c != 'e' && c != 'E') {
7287                 i = PERL_INT_MIN;
7288                 (void)Perl_frexp(nv, &i);
7289                 if (i == PERL_INT_MIN)
7290                     Perl_die(aTHX_ "panic: frexp");
7291                 if (i > 0)
7292                     need = BIT_DIGITS(i);
7293             }
7294             need += has_precis ? precis : 6; /* known default */
7295             if (need < width)
7296                 need = width;
7297
7298             need += 20; /* fudge factor */
7299             if (PL_efloatsize < need) {
7300                 Safefree(PL_efloatbuf);
7301                 PL_efloatsize = need + 20; /* more fudge */
7302                 New(906, PL_efloatbuf, PL_efloatsize, char);
7303                 PL_efloatbuf[0] = '\0';
7304             }
7305
7306             eptr = ebuf + sizeof ebuf;
7307             *--eptr = '\0';
7308             *--eptr = c;
7309 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7310             {
7311                 /* Copy the one or more characters in a long double
7312                  * format before the 'base' ([efgEFG]) character to
7313                  * the format string. */
7314                 static char const prifldbl[] = PERL_PRIfldbl;
7315                 char const *p = prifldbl + sizeof(prifldbl) - 3;
7316                 while (p >= prifldbl) { *--eptr = *p--; }
7317             }
7318 #endif
7319             if (has_precis) {
7320                 base = precis;
7321                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7322                 *--eptr = '.';
7323             }
7324             if (width) {
7325                 base = width;
7326                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7327             }
7328             if (fill == '0')
7329                 *--eptr = fill;
7330             if (left)
7331                 *--eptr = '-';
7332             if (plus)
7333                 *--eptr = plus;
7334             if (alt)
7335                 *--eptr = '#';
7336             *--eptr = '%';
7337
7338             /* No taint.  Otherwise we are in the strange situation
7339              * where printf() taints but print($float) doesn't.
7340              * --jhi */
7341             (void)sprintf(PL_efloatbuf, eptr, nv);
7342
7343             eptr = PL_efloatbuf;
7344             elen = strlen(PL_efloatbuf);
7345             break;
7346
7347             /* SPECIAL */
7348
7349         case 'n':
7350             vectorize = FALSE;
7351             i = SvCUR(sv) - origlen;
7352             if (args) {
7353                 switch (intsize) {
7354                 case 'h':       *(va_arg(*args, short*)) = i; break;
7355                 default:        *(va_arg(*args, int*)) = i; break;
7356                 case 'l':       *(va_arg(*args, long*)) = i; break;
7357                 case 'V':       *(va_arg(*args, IV*)) = i; break;
7358 #ifdef HAS_QUAD
7359                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
7360 #endif
7361                 }
7362             }
7363             else if (epix ? epix <= svmax : svix < svmax)
7364                 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
7365             continue;   /* not "break" */
7366
7367             /* UNKNOWN */
7368
7369         default:
7370       unknown:
7371             vectorize = FALSE;
7372             if (!args && ckWARN(WARN_PRINTF) &&
7373                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7374                 SV *msg = sv_newmortal();
7375                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7376                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7377                 if (c) {
7378                     if (isPRINT(c))
7379                         Perl_sv_catpvf(aTHX_ msg,
7380                                        "\"%%%c\"", c & 0xFF);
7381                     else
7382                         Perl_sv_catpvf(aTHX_ msg,
7383                                        "\"%%\\%03"UVof"\"",
7384                                        (UV)c & 0xFF);
7385                 } else
7386                     sv_catpv(msg, "end of string");
7387                 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7388             }
7389
7390             /* output mangled stuff ... */
7391             if (c == '\0')
7392                 --q;
7393             eptr = p;
7394             elen = q - p;
7395
7396             /* ... right here, because formatting flags should not apply */
7397             SvGROW(sv, SvCUR(sv) + elen + 1);
7398             p = SvEND(sv);
7399             memcpy(p, eptr, elen);
7400             p += elen;
7401             *p = '\0';
7402             SvCUR(sv) = p - SvPVX(sv);
7403             continue;   /* not "break" */
7404         }
7405
7406         have = esignlen + zeros + elen;
7407         need = (have > width ? have : width);
7408         gap = need - have;
7409
7410         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7411         p = SvEND(sv);
7412         if (esignlen && fill == '0') {
7413             for (i = 0; i < esignlen; i++)
7414                 *p++ = esignbuf[i];
7415         }
7416         if (gap && !left) {
7417             memset(p, fill, gap);
7418             p += gap;
7419         }
7420         if (esignlen && fill != '0') {
7421             for (i = 0; i < esignlen; i++)
7422                 *p++ = esignbuf[i];
7423         }
7424         if (zeros) {
7425             for (i = zeros; i; i--)
7426                 *p++ = '0';
7427         }
7428         if (elen) {
7429             memcpy(p, eptr, elen);
7430             p += elen;
7431         }
7432         if (gap && left) {
7433             memset(p, ' ', gap);
7434             p += gap;
7435         }
7436         if (vectorize) {
7437             if (veclen) {
7438                 memcpy(p, dotstr, dotstrlen);
7439                 p += dotstrlen;
7440             }
7441             else
7442                 vectorize = FALSE;              /* done iterating over vecstr */
7443         }
7444         if (is_utf)
7445             SvUTF8_on(sv);
7446         *p = '\0';
7447         SvCUR(sv) = p - SvPVX(sv);
7448         if (vectorize) {
7449             esignlen = 0;
7450             goto vector;
7451         }
7452     }
7453 }
7454
7455 #if defined(USE_ITHREADS)
7456
7457 #if defined(USE_THREADS)
7458 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
7459 #endif
7460
7461 #ifndef GpREFCNT_inc
7462 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7463 #endif
7464
7465
7466 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
7467 #define av_dup(s)       (AV*)sv_dup((SV*)s)
7468 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7469 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
7470 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7471 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
7472 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7473 #define io_dup(s)       (IO*)sv_dup((SV*)s)
7474 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7475 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
7476 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7477 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
7478 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
7479
7480 REGEXP *
7481 Perl_re_dup(pTHX_ REGEXP *r)
7482 {
7483     /* XXX fix when pmop->op_pmregexp becomes shared */
7484     return ReREFCNT_inc(r);
7485 }
7486
7487 PerlIO *
7488 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7489 {
7490     PerlIO *ret;
7491     if (!fp)
7492         return (PerlIO*)NULL;
7493
7494     /* look for it in the table first */
7495     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7496     if (ret)
7497         return ret;
7498
7499     /* create anew and remember what it is */
7500     ret = PerlIO_fdupopen(aTHX_ fp);
7501     ptr_table_store(PL_ptr_table, fp, ret);
7502     return ret;
7503 }
7504
7505 DIR *
7506 Perl_dirp_dup(pTHX_ DIR *dp)
7507 {
7508     if (!dp)
7509         return (DIR*)NULL;
7510     /* XXX TODO */
7511     return dp;
7512 }
7513
7514 GP *
7515 Perl_gp_dup(pTHX_ GP *gp)
7516 {
7517     GP *ret;
7518     if (!gp)
7519         return (GP*)NULL;
7520     /* look for it in the table first */
7521     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7522     if (ret)
7523         return ret;
7524
7525     /* create anew and remember what it is */
7526     Newz(0, ret, 1, GP);
7527     ptr_table_store(PL_ptr_table, gp, ret);
7528
7529     /* clone */
7530     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
7531     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
7532     ret->gp_io          = io_dup_inc(gp->gp_io);
7533     ret->gp_form        = cv_dup_inc(gp->gp_form);
7534     ret->gp_av          = av_dup_inc(gp->gp_av);
7535     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
7536     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
7537     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
7538     ret->gp_cvgen       = gp->gp_cvgen;
7539     ret->gp_flags       = gp->gp_flags;
7540     ret->gp_line        = gp->gp_line;
7541     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
7542     return ret;
7543 }
7544
7545 MAGIC *
7546 Perl_mg_dup(pTHX_ MAGIC *mg)
7547 {
7548     MAGIC *mgret = (MAGIC*)NULL;
7549     MAGIC *mgprev;
7550     if (!mg)
7551         return (MAGIC*)NULL;
7552     /* look for it in the table first */
7553     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7554     if (mgret)
7555         return mgret;
7556
7557     for (; mg; mg = mg->mg_moremagic) {
7558         MAGIC *nmg;
7559         Newz(0, nmg, 1, MAGIC);
7560         if (!mgret)
7561             mgret = nmg;
7562         else
7563             mgprev->mg_moremagic = nmg;
7564         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
7565         nmg->mg_private = mg->mg_private;
7566         nmg->mg_type    = mg->mg_type;
7567         nmg->mg_flags   = mg->mg_flags;
7568         if (mg->mg_type == 'r') {
7569             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7570         }
7571         else {
7572             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7573                               ? sv_dup_inc(mg->mg_obj)
7574                               : sv_dup(mg->mg_obj);
7575         }
7576         nmg->mg_len     = mg->mg_len;
7577         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
7578         if (mg->mg_ptr && mg->mg_type != 'g') {
7579             if (mg->mg_len >= 0) {
7580                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
7581                 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7582                     AMT *amtp = (AMT*)mg->mg_ptr;
7583                     AMT *namtp = (AMT*)nmg->mg_ptr;
7584                     I32 i;
7585                     for (i = 1; i < NofAMmeth; i++) {
7586                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
7587                     }
7588                 }
7589             }
7590             else if (mg->mg_len == HEf_SVKEY)
7591                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7592         }
7593         mgprev = nmg;
7594     }
7595     return mgret;
7596 }
7597
7598 PTR_TBL_t *
7599 Perl_ptr_table_new(pTHX)
7600 {
7601     PTR_TBL_t *tbl;
7602     Newz(0, tbl, 1, PTR_TBL_t);
7603     tbl->tbl_max        = 511;
7604     tbl->tbl_items      = 0;
7605     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7606     return tbl;
7607 }
7608
7609 void *
7610 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7611 {
7612     PTR_TBL_ENT_t *tblent;
7613     UV hash = PTR2UV(sv);
7614     assert(tbl);
7615     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7616     for (; tblent; tblent = tblent->next) {
7617         if (tblent->oldval == sv)
7618             return tblent->newval;
7619     }
7620     return (void*)NULL;
7621 }
7622
7623 void
7624 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7625 {
7626     PTR_TBL_ENT_t *tblent, **otblent;
7627     /* XXX this may be pessimal on platforms where pointers aren't good
7628      * hash values e.g. if they grow faster in the most significant
7629      * bits */
7630     UV hash = PTR2UV(oldv);
7631     bool i = 1;
7632
7633     assert(tbl);
7634     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7635     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7636         if (tblent->oldval == oldv) {
7637             tblent->newval = newv;
7638             tbl->tbl_items++;
7639             return;
7640         }
7641     }
7642     Newz(0, tblent, 1, PTR_TBL_ENT_t);
7643     tblent->oldval = oldv;
7644     tblent->newval = newv;
7645     tblent->next = *otblent;
7646     *otblent = tblent;
7647     tbl->tbl_items++;
7648     if (i && tbl->tbl_items > tbl->tbl_max)
7649         ptr_table_split(tbl);
7650 }
7651
7652 void
7653 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7654 {
7655     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7656     UV oldsize = tbl->tbl_max + 1;
7657     UV newsize = oldsize * 2;
7658     UV i;
7659
7660     Renew(ary, newsize, PTR_TBL_ENT_t*);
7661     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7662     tbl->tbl_max = --newsize;
7663     tbl->tbl_ary = ary;
7664     for (i=0; i < oldsize; i++, ary++) {
7665         PTR_TBL_ENT_t **curentp, **entp, *ent;
7666         if (!*ary)
7667             continue;
7668         curentp = ary + oldsize;
7669         for (entp = ary, ent = *ary; ent; ent = *entp) {
7670             if ((newsize & PTR2UV(ent->oldval)) != i) {
7671                 *entp = ent->next;
7672                 ent->next = *curentp;
7673                 *curentp = ent;
7674                 continue;
7675             }
7676             else
7677                 entp = &ent->next;
7678         }
7679     }
7680 }
7681
7682 #ifdef DEBUGGING
7683 char *PL_watch_pvx;
7684 #endif
7685
7686 SV *
7687 Perl_sv_dup(pTHX_ SV *sstr)
7688 {
7689     SV *dstr;
7690
7691     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7692         return Nullsv;
7693     /* look for it in the table first */
7694     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7695     if (dstr)
7696         return dstr;
7697
7698     /* create anew and remember what it is */
7699     new_SV(dstr);
7700     ptr_table_store(PL_ptr_table, sstr, dstr);
7701
7702     /* clone */
7703     SvFLAGS(dstr)       = SvFLAGS(sstr);
7704     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
7705     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
7706
7707 #ifdef DEBUGGING
7708     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7709         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7710                       PL_watch_pvx, SvPVX(sstr));
7711 #endif
7712
7713     switch (SvTYPE(sstr)) {
7714     case SVt_NULL:
7715         SvANY(dstr)     = NULL;
7716         break;
7717     case SVt_IV:
7718         SvANY(dstr)     = new_XIV();
7719         SvIVX(dstr)     = SvIVX(sstr);
7720         break;
7721     case SVt_NV:
7722         SvANY(dstr)     = new_XNV();
7723         SvNVX(dstr)     = SvNVX(sstr);
7724         break;
7725     case SVt_RV:
7726         SvANY(dstr)     = new_XRV();
7727         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
7728         break;
7729     case SVt_PV:
7730         SvANY(dstr)     = new_XPV();
7731         SvCUR(dstr)     = SvCUR(sstr);
7732         SvLEN(dstr)     = SvLEN(sstr);
7733         if (SvROK(sstr))
7734             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7735         else if (SvPVX(sstr) && SvLEN(sstr))
7736             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7737         else
7738             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7739         break;
7740     case SVt_PVIV:
7741         SvANY(dstr)     = new_XPVIV();
7742         SvCUR(dstr)     = SvCUR(sstr);
7743         SvLEN(dstr)     = SvLEN(sstr);
7744         SvIVX(dstr)     = SvIVX(sstr);
7745         if (SvROK(sstr))
7746             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7747         else if (SvPVX(sstr) && SvLEN(sstr))
7748             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7749         else
7750             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7751         break;
7752     case SVt_PVNV:
7753         SvANY(dstr)     = new_XPVNV();
7754         SvCUR(dstr)     = SvCUR(sstr);
7755         SvLEN(dstr)     = SvLEN(sstr);
7756         SvIVX(dstr)     = SvIVX(sstr);
7757         SvNVX(dstr)     = SvNVX(sstr);
7758         if (SvROK(sstr))
7759             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7760         else if (SvPVX(sstr) && SvLEN(sstr))
7761             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7762         else
7763             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7764         break;
7765     case SVt_PVMG:
7766         SvANY(dstr)     = new_XPVMG();
7767         SvCUR(dstr)     = SvCUR(sstr);
7768         SvLEN(dstr)     = SvLEN(sstr);
7769         SvIVX(dstr)     = SvIVX(sstr);
7770         SvNVX(dstr)     = SvNVX(sstr);
7771         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7772         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7773         if (SvROK(sstr))
7774             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7775         else if (SvPVX(sstr) && SvLEN(sstr))
7776             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7777         else
7778             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7779         break;
7780     case SVt_PVBM:
7781         SvANY(dstr)     = new_XPVBM();
7782         SvCUR(dstr)     = SvCUR(sstr);
7783         SvLEN(dstr)     = SvLEN(sstr);
7784         SvIVX(dstr)     = SvIVX(sstr);
7785         SvNVX(dstr)     = SvNVX(sstr);
7786         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7787         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7788         if (SvROK(sstr))
7789             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7790         else if (SvPVX(sstr) && SvLEN(sstr))
7791             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7792         else
7793             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7794         BmRARE(dstr)    = BmRARE(sstr);
7795         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
7796         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7797         break;
7798     case SVt_PVLV:
7799         SvANY(dstr)     = new_XPVLV();
7800         SvCUR(dstr)     = SvCUR(sstr);
7801         SvLEN(dstr)     = SvLEN(sstr);
7802         SvIVX(dstr)     = SvIVX(sstr);
7803         SvNVX(dstr)     = SvNVX(sstr);
7804         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7805         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7806         if (SvROK(sstr))
7807             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7808         else if (SvPVX(sstr) && SvLEN(sstr))
7809             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7810         else
7811             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7812         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
7813         LvTARGLEN(dstr) = LvTARGLEN(sstr);
7814         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
7815         LvTYPE(dstr)    = LvTYPE(sstr);
7816         break;
7817     case SVt_PVGV:
7818         SvANY(dstr)     = new_XPVGV();
7819         SvCUR(dstr)     = SvCUR(sstr);
7820         SvLEN(dstr)     = SvLEN(sstr);
7821         SvIVX(dstr)     = SvIVX(sstr);
7822         SvNVX(dstr)     = SvNVX(sstr);
7823         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7824         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7825         if (SvROK(sstr))
7826             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7827         else if (SvPVX(sstr) && SvLEN(sstr))
7828             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7829         else
7830             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7831         GvNAMELEN(dstr) = GvNAMELEN(sstr);
7832         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7833         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
7834         GvFLAGS(dstr)   = GvFLAGS(sstr);
7835         GvGP(dstr)      = gp_dup(GvGP(sstr));
7836         (void)GpREFCNT_inc(GvGP(dstr));
7837         break;
7838     case SVt_PVIO:
7839         SvANY(dstr)     = new_XPVIO();
7840         SvCUR(dstr)     = SvCUR(sstr);
7841         SvLEN(dstr)     = SvLEN(sstr);
7842         SvIVX(dstr)     = SvIVX(sstr);
7843         SvNVX(dstr)     = SvNVX(sstr);
7844         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7845         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7846         if (SvROK(sstr))
7847             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7848         else if (SvPVX(sstr) && SvLEN(sstr))
7849             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7850         else
7851             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7852         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7853         if (IoOFP(sstr) == IoIFP(sstr))
7854             IoOFP(dstr) = IoIFP(dstr);
7855         else
7856             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7857         /* PL_rsfp_filters entries have fake IoDIRP() */
7858         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7859             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
7860         else
7861             IoDIRP(dstr)        = IoDIRP(sstr);
7862         IoLINES(dstr)           = IoLINES(sstr);
7863         IoPAGE(dstr)            = IoPAGE(sstr);
7864         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
7865         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
7866         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
7867         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
7868         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
7869         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
7870         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
7871         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
7872         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
7873         IoTYPE(dstr)            = IoTYPE(sstr);
7874         IoFLAGS(dstr)           = IoFLAGS(sstr);
7875         break;
7876     case SVt_PVAV:
7877         SvANY(dstr)     = new_XPVAV();
7878         SvCUR(dstr)     = SvCUR(sstr);
7879         SvLEN(dstr)     = SvLEN(sstr);
7880         SvIVX(dstr)     = SvIVX(sstr);
7881         SvNVX(dstr)     = SvNVX(sstr);
7882         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7883         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7884         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7885         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7886         if (AvARRAY((AV*)sstr)) {
7887             SV **dst_ary, **src_ary;
7888             SSize_t items = AvFILLp((AV*)sstr) + 1;
7889
7890             src_ary = AvARRAY((AV*)sstr);
7891             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7892             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7893             SvPVX(dstr) = (char*)dst_ary;
7894             AvALLOC((AV*)dstr) = dst_ary;
7895             if (AvREAL((AV*)sstr)) {
7896                 while (items-- > 0)
7897                     *dst_ary++ = sv_dup_inc(*src_ary++);
7898             }
7899             else {
7900                 while (items-- > 0)
7901                     *dst_ary++ = sv_dup(*src_ary++);
7902             }
7903             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7904             while (items-- > 0) {
7905                 *dst_ary++ = &PL_sv_undef;
7906             }
7907         }
7908         else {
7909             SvPVX(dstr)         = Nullch;
7910             AvALLOC((AV*)dstr)  = (SV**)NULL;
7911         }
7912         break;
7913     case SVt_PVHV:
7914         SvANY(dstr)     = new_XPVHV();
7915         SvCUR(dstr)     = SvCUR(sstr);
7916         SvLEN(dstr)     = SvLEN(sstr);
7917         SvIVX(dstr)     = SvIVX(sstr);
7918         SvNVX(dstr)     = SvNVX(sstr);
7919         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7920         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7921         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
7922         if (HvARRAY((HV*)sstr)) {
7923             STRLEN i = 0;
7924             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7925             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7926             Newz(0, dxhv->xhv_array,
7927                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7928             while (i <= sxhv->xhv_max) {
7929                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7930                                                     !!HvSHAREKEYS(sstr));
7931                 ++i;
7932             }
7933             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7934         }
7935         else {
7936             SvPVX(dstr)         = Nullch;
7937             HvEITER((HV*)dstr)  = (HE*)NULL;
7938         }
7939         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
7940         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
7941         break;
7942     case SVt_PVFM:
7943         SvANY(dstr)     = new_XPVFM();
7944         FmLINES(dstr)   = FmLINES(sstr);
7945         goto dup_pvcv;
7946         /* NOTREACHED */
7947     case SVt_PVCV:
7948         SvANY(dstr)     = new_XPVCV();
7949 dup_pvcv:
7950         SvCUR(dstr)     = SvCUR(sstr);
7951         SvLEN(dstr)     = SvLEN(sstr);
7952         SvIVX(dstr)     = SvIVX(sstr);
7953         SvNVX(dstr)     = SvNVX(sstr);
7954         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7955         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7956         if (SvPVX(sstr) && SvLEN(sstr))
7957             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7958         else
7959             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7960         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7961         CvSTART(dstr)   = CvSTART(sstr);
7962         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
7963         CvXSUB(dstr)    = CvXSUB(sstr);
7964         CvXSUBANY(dstr) = CvXSUBANY(sstr);
7965         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
7966         CvDEPTH(dstr)   = CvDEPTH(sstr);
7967         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7968             /* XXX padlists are real, but pretend to be not */
7969             AvREAL_on(CvPADLIST(sstr));
7970             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
7971             AvREAL_off(CvPADLIST(sstr));
7972             AvREAL_off(CvPADLIST(dstr));
7973         }
7974         else
7975             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
7976         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7977         CvFLAGS(dstr)   = CvFLAGS(sstr);
7978         break;
7979     default:
7980         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7981         break;
7982     }
7983
7984     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7985         ++PL_sv_objcount;
7986
7987     return dstr;
7988 }
7989
7990 PERL_CONTEXT *
7991 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7992 {
7993     PERL_CONTEXT *ncxs;
7994
7995     if (!cxs)
7996         return (PERL_CONTEXT*)NULL;
7997
7998     /* look for it in the table first */
7999     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8000     if (ncxs)
8001         return ncxs;
8002
8003     /* create anew and remember what it is */
8004     Newz(56, ncxs, max + 1, PERL_CONTEXT);
8005     ptr_table_store(PL_ptr_table, cxs, ncxs);
8006
8007     while (ix >= 0) {
8008         PERL_CONTEXT *cx = &cxs[ix];
8009         PERL_CONTEXT *ncx = &ncxs[ix];
8010         ncx->cx_type    = cx->cx_type;
8011         if (CxTYPE(cx) == CXt_SUBST) {
8012             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8013         }
8014         else {
8015             ncx->blk_oldsp      = cx->blk_oldsp;
8016             ncx->blk_oldcop     = cx->blk_oldcop;
8017             ncx->blk_oldretsp   = cx->blk_oldretsp;
8018             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
8019             ncx->blk_oldscopesp = cx->blk_oldscopesp;
8020             ncx->blk_oldpm      = cx->blk_oldpm;
8021             ncx->blk_gimme      = cx->blk_gimme;
8022             switch (CxTYPE(cx)) {
8023             case CXt_SUB:
8024                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
8025                                            ? cv_dup_inc(cx->blk_sub.cv)
8026                                            : cv_dup(cx->blk_sub.cv));
8027                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
8028                                            ? av_dup_inc(cx->blk_sub.argarray)
8029                                            : Nullav);
8030                 ncx->blk_sub.savearray  = av_dup(cx->blk_sub.savearray);
8031                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
8032                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
8033                 ncx->blk_sub.lval       = cx->blk_sub.lval;
8034                 break;
8035             case CXt_EVAL:
8036                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8037                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8038                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8039                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8040                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text);
8041                 break;
8042             case CXt_LOOP:
8043                 ncx->blk_loop.label     = cx->blk_loop.label;
8044                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
8045                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
8046                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
8047                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
8048                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
8049                                            ? cx->blk_loop.iterdata
8050                                            : gv_dup((GV*)cx->blk_loop.iterdata));
8051                 ncx->blk_loop.oldcurpad
8052                     = (SV**)ptr_table_fetch(PL_ptr_table,
8053                                             cx->blk_loop.oldcurpad);
8054                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave);
8055                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval);
8056                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary);
8057                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
8058                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
8059                 break;
8060             case CXt_FORMAT:
8061                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv);
8062                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv);
8063                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv);
8064                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
8065                 break;
8066             case CXt_BLOCK:
8067             case CXt_NULL:
8068                 break;
8069             }
8070         }
8071         --ix;
8072     }
8073     return ncxs;
8074 }
8075
8076 PERL_SI *
8077 Perl_si_dup(pTHX_ PERL_SI *si)
8078 {
8079     PERL_SI *nsi;
8080
8081     if (!si)
8082         return (PERL_SI*)NULL;
8083
8084     /* look for it in the table first */
8085     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8086     if (nsi)
8087         return nsi;
8088
8089     /* create anew and remember what it is */
8090     Newz(56, nsi, 1, PERL_SI);
8091     ptr_table_store(PL_ptr_table, si, nsi);
8092
8093     nsi->si_stack       = av_dup_inc(si->si_stack);
8094     nsi->si_cxix        = si->si_cxix;
8095     nsi->si_cxmax       = si->si_cxmax;
8096     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8097     nsi->si_type        = si->si_type;
8098     nsi->si_prev        = si_dup(si->si_prev);
8099     nsi->si_next        = si_dup(si->si_next);
8100     nsi->si_markoff     = si->si_markoff;
8101
8102     return nsi;
8103 }
8104
8105 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
8106 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
8107 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
8108 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
8109 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
8110 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
8111 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
8112 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
8113 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
8114 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
8115 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8116 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8117
8118 /* XXXXX todo */
8119 #define pv_dup_inc(p)   SAVEPV(p)
8120 #define pv_dup(p)       SAVEPV(p)
8121 #define svp_dup_inc(p,pp)       any_dup(p,pp)
8122
8123 void *
8124 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8125 {
8126     void *ret;
8127
8128     if (!v)
8129         return (void*)NULL;
8130
8131     /* look for it in the table first */
8132     ret = ptr_table_fetch(PL_ptr_table, v);
8133     if (ret)
8134         return ret;
8135
8136     /* see if it is part of the interpreter structure */
8137     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8138         ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8139     else
8140         ret = v;
8141
8142     return ret;
8143 }
8144
8145 ANY *
8146 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8147 {
8148     ANY *ss     = proto_perl->Tsavestack;
8149     I32 ix      = proto_perl->Tsavestack_ix;
8150     I32 max     = proto_perl->Tsavestack_max;
8151     ANY *nss;
8152     SV *sv;
8153     GV *gv;
8154     AV *av;
8155     HV *hv;
8156     void* ptr;
8157     int intval;
8158     long longval;
8159     GP *gp;
8160     IV iv;
8161     I32 i;
8162     char *c;
8163     void (*dptr) (void*);
8164     void (*dxptr) (pTHXo_ void*);
8165     OP *o;
8166
8167     Newz(54, nss, max, ANY);
8168
8169     while (ix > 0) {
8170         i = POPINT(ss,ix);
8171         TOPINT(nss,ix) = i;
8172         switch (i) {
8173         case SAVEt_ITEM:                        /* normal string */
8174             sv = (SV*)POPPTR(ss,ix);
8175             TOPPTR(nss,ix) = sv_dup_inc(sv);
8176             sv = (SV*)POPPTR(ss,ix);
8177             TOPPTR(nss,ix) = sv_dup_inc(sv);
8178             break;
8179         case SAVEt_SV:                          /* scalar reference */
8180             sv = (SV*)POPPTR(ss,ix);
8181             TOPPTR(nss,ix) = sv_dup_inc(sv);
8182             gv = (GV*)POPPTR(ss,ix);
8183             TOPPTR(nss,ix) = gv_dup_inc(gv);
8184             break;
8185         case SAVEt_GENERIC_PVREF:               /* generic char* */
8186             c = (char*)POPPTR(ss,ix);
8187             TOPPTR(nss,ix) = pv_dup(c);
8188             ptr = POPPTR(ss,ix);
8189             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8190             break;
8191         case SAVEt_GENERIC_SVREF:               /* generic sv */
8192         case SAVEt_SVREF:                       /* scalar reference */
8193             sv = (SV*)POPPTR(ss,ix);
8194             TOPPTR(nss,ix) = sv_dup_inc(sv);
8195             ptr = POPPTR(ss,ix);
8196             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8197             break;
8198         case SAVEt_AV:                          /* array reference */
8199             av = (AV*)POPPTR(ss,ix);
8200             TOPPTR(nss,ix) = av_dup_inc(av);
8201             gv = (GV*)POPPTR(ss,ix);
8202             TOPPTR(nss,ix) = gv_dup(gv);
8203             break;
8204         case SAVEt_HV:                          /* hash reference */
8205             hv = (HV*)POPPTR(ss,ix);
8206             TOPPTR(nss,ix) = hv_dup_inc(hv);
8207             gv = (GV*)POPPTR(ss,ix);
8208             TOPPTR(nss,ix) = gv_dup(gv);
8209             break;
8210         case SAVEt_INT:                         /* int reference */
8211             ptr = POPPTR(ss,ix);
8212             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8213             intval = (int)POPINT(ss,ix);
8214             TOPINT(nss,ix) = intval;
8215             break;
8216         case SAVEt_LONG:                        /* long reference */
8217             ptr = POPPTR(ss,ix);
8218             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8219             longval = (long)POPLONG(ss,ix);
8220             TOPLONG(nss,ix) = longval;
8221             break;
8222         case SAVEt_I32:                         /* I32 reference */
8223         case SAVEt_I16:                         /* I16 reference */
8224         case SAVEt_I8:                          /* I8 reference */
8225             ptr = POPPTR(ss,ix);
8226             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8227             i = POPINT(ss,ix);
8228             TOPINT(nss,ix) = i;
8229             break;
8230         case SAVEt_IV:                          /* IV reference */
8231             ptr = POPPTR(ss,ix);
8232             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8233             iv = POPIV(ss,ix);
8234             TOPIV(nss,ix) = iv;
8235             break;
8236         case SAVEt_SPTR:                        /* SV* reference */
8237             ptr = POPPTR(ss,ix);
8238             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8239             sv = (SV*)POPPTR(ss,ix);
8240             TOPPTR(nss,ix) = sv_dup(sv);
8241             break;
8242         case SAVEt_VPTR:                        /* random* reference */
8243             ptr = POPPTR(ss,ix);
8244             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8245             ptr = POPPTR(ss,ix);
8246             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8247             break;
8248         case SAVEt_PPTR:                        /* char* reference */
8249             ptr = POPPTR(ss,ix);
8250             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8251             c = (char*)POPPTR(ss,ix);
8252             TOPPTR(nss,ix) = pv_dup(c);
8253             break;
8254         case SAVEt_HPTR:                        /* HV* reference */
8255             ptr = POPPTR(ss,ix);
8256             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8257             hv = (HV*)POPPTR(ss,ix);
8258             TOPPTR(nss,ix) = hv_dup(hv);
8259             break;
8260         case SAVEt_APTR:                        /* AV* reference */
8261             ptr = POPPTR(ss,ix);
8262             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8263             av = (AV*)POPPTR(ss,ix);
8264             TOPPTR(nss,ix) = av_dup(av);
8265             break;
8266         case SAVEt_NSTAB:
8267             gv = (GV*)POPPTR(ss,ix);
8268             TOPPTR(nss,ix) = gv_dup(gv);
8269             break;
8270         case SAVEt_GP:                          /* scalar reference */
8271             gp = (GP*)POPPTR(ss,ix);
8272             TOPPTR(nss,ix) = gp = gp_dup(gp);
8273             (void)GpREFCNT_inc(gp);
8274             gv = (GV*)POPPTR(ss,ix);
8275             TOPPTR(nss,ix) = gv_dup_inc(c);
8276             c = (char*)POPPTR(ss,ix);
8277             TOPPTR(nss,ix) = pv_dup(c);
8278             iv = POPIV(ss,ix);
8279             TOPIV(nss,ix) = iv;
8280             iv = POPIV(ss,ix);
8281             TOPIV(nss,ix) = iv;
8282             break;
8283         case SAVEt_FREESV:
8284             sv = (SV*)POPPTR(ss,ix);
8285             TOPPTR(nss,ix) = sv_dup_inc(sv);
8286             break;
8287         case SAVEt_FREEOP:
8288             ptr = POPPTR(ss,ix);
8289             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8290                 /* these are assumed to be refcounted properly */
8291                 switch (((OP*)ptr)->op_type) {
8292                 case OP_LEAVESUB:
8293                 case OP_LEAVESUBLV:
8294                 case OP_LEAVEEVAL:
8295                 case OP_LEAVE:
8296                 case OP_SCOPE:
8297                 case OP_LEAVEWRITE:
8298                     TOPPTR(nss,ix) = ptr;
8299                     o = (OP*)ptr;
8300                     OpREFCNT_inc(o);
8301                     break;
8302                 default:
8303                     TOPPTR(nss,ix) = Nullop;
8304                     break;
8305                 }
8306             }
8307             else
8308                 TOPPTR(nss,ix) = Nullop;
8309             break;
8310         case SAVEt_FREEPV:
8311             c = (char*)POPPTR(ss,ix);
8312             TOPPTR(nss,ix) = pv_dup_inc(c);
8313             break;
8314         case SAVEt_CLEARSV:
8315             longval = POPLONG(ss,ix);
8316             TOPLONG(nss,ix) = longval;
8317             break;
8318         case SAVEt_DELETE:
8319             hv = (HV*)POPPTR(ss,ix);
8320             TOPPTR(nss,ix) = hv_dup_inc(hv);
8321             c = (char*)POPPTR(ss,ix);
8322             TOPPTR(nss,ix) = pv_dup_inc(c);
8323             i = POPINT(ss,ix);
8324             TOPINT(nss,ix) = i;
8325             break;
8326         case SAVEt_DESTRUCTOR:
8327             ptr = POPPTR(ss,ix);
8328             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
8329             dptr = POPDPTR(ss,ix);
8330             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8331             break;
8332         case SAVEt_DESTRUCTOR_X:
8333             ptr = POPPTR(ss,ix);
8334             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
8335             dxptr = POPDXPTR(ss,ix);
8336             TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8337             break;
8338         case SAVEt_REGCONTEXT:
8339         case SAVEt_ALLOC:
8340             i = POPINT(ss,ix);
8341             TOPINT(nss,ix) = i;
8342             ix -= i;
8343             break;
8344         case SAVEt_STACK_POS:           /* Position on Perl stack */
8345             i = POPINT(ss,ix);
8346             TOPINT(nss,ix) = i;
8347             break;
8348         case SAVEt_AELEM:               /* array element */
8349             sv = (SV*)POPPTR(ss,ix);
8350             TOPPTR(nss,ix) = sv_dup_inc(sv);
8351             i = POPINT(ss,ix);
8352             TOPINT(nss,ix) = i;
8353             av = (AV*)POPPTR(ss,ix);
8354             TOPPTR(nss,ix) = av_dup_inc(av);
8355             break;
8356         case SAVEt_HELEM:               /* hash element */
8357             sv = (SV*)POPPTR(ss,ix);
8358             TOPPTR(nss,ix) = sv_dup_inc(sv);
8359             sv = (SV*)POPPTR(ss,ix);
8360             TOPPTR(nss,ix) = sv_dup_inc(sv);
8361             hv = (HV*)POPPTR(ss,ix);
8362             TOPPTR(nss,ix) = hv_dup_inc(hv);
8363             break;
8364         case SAVEt_OP:
8365             ptr = POPPTR(ss,ix);
8366             TOPPTR(nss,ix) = ptr;
8367             break;
8368         case SAVEt_HINTS:
8369             i = POPINT(ss,ix);
8370             TOPINT(nss,ix) = i;
8371             break;
8372         case SAVEt_COMPPAD:
8373             av = (AV*)POPPTR(ss,ix);
8374             TOPPTR(nss,ix) = av_dup(av);
8375             break;
8376         case SAVEt_PADSV:
8377             longval = (long)POPLONG(ss,ix);
8378             TOPLONG(nss,ix) = longval;
8379             ptr = POPPTR(ss,ix);
8380             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8381             sv = (SV*)POPPTR(ss,ix);
8382             TOPPTR(nss,ix) = sv_dup(sv);
8383             break;
8384         default:
8385             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8386         }
8387     }
8388
8389     return nss;
8390 }
8391
8392 #ifdef PERL_OBJECT
8393 #include "XSUB.h"
8394 #endif
8395
8396 PerlInterpreter *
8397 perl_clone(PerlInterpreter *proto_perl, UV flags)
8398 {
8399 #ifdef PERL_OBJECT
8400     CPerlObj *pPerl = (CPerlObj*)proto_perl;
8401 #endif
8402
8403 #ifdef PERL_IMPLICIT_SYS
8404     return perl_clone_using(proto_perl, flags,
8405                             proto_perl->IMem,
8406                             proto_perl->IMemShared,
8407                             proto_perl->IMemParse,
8408                             proto_perl->IEnv,
8409                             proto_perl->IStdIO,
8410                             proto_perl->ILIO,
8411                             proto_perl->IDir,
8412                             proto_perl->ISock,
8413                             proto_perl->IProc);
8414 }
8415
8416 PerlInterpreter *
8417 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8418                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
8419                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8420                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8421                  struct IPerlDir* ipD, struct IPerlSock* ipS,
8422                  struct IPerlProc* ipP)
8423 {
8424     /* XXX many of the string copies here can be optimized if they're
8425      * constants; they need to be allocated as common memory and just
8426      * their pointers copied. */
8427
8428     IV i;
8429 #  ifdef PERL_OBJECT
8430     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8431                                         ipD, ipS, ipP);
8432     PERL_SET_THX(pPerl);
8433 #  else         /* !PERL_OBJECT */
8434     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8435     PERL_SET_THX(my_perl);
8436
8437 #    ifdef DEBUGGING
8438     memset(my_perl, 0xab, sizeof(PerlInterpreter));
8439     PL_markstack = 0;
8440     PL_scopestack = 0;
8441     PL_savestack = 0;
8442     PL_retstack = 0;
8443 #    else       /* !DEBUGGING */
8444     Zero(my_perl, 1, PerlInterpreter);
8445 #    endif      /* DEBUGGING */
8446
8447     /* host pointers */
8448     PL_Mem              = ipM;
8449     PL_MemShared        = ipMS;
8450     PL_MemParse         = ipMP;
8451     PL_Env              = ipE;
8452     PL_StdIO            = ipStd;
8453     PL_LIO              = ipLIO;
8454     PL_Dir              = ipD;
8455     PL_Sock             = ipS;
8456     PL_Proc             = ipP;
8457 #  endif        /* PERL_OBJECT */
8458 #else           /* !PERL_IMPLICIT_SYS */
8459     IV i;
8460     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8461     PERL_SET_THX(my_perl);
8462
8463 #    ifdef DEBUGGING
8464     memset(my_perl, 0xab, sizeof(PerlInterpreter));
8465     PL_markstack = 0;
8466     PL_scopestack = 0;
8467     PL_savestack = 0;
8468     PL_retstack = 0;
8469 #    else       /* !DEBUGGING */
8470     Zero(my_perl, 1, PerlInterpreter);
8471 #    endif      /* DEBUGGING */
8472 #endif          /* PERL_IMPLICIT_SYS */
8473
8474     /* arena roots */
8475     PL_xiv_arenaroot    = NULL;
8476     PL_xiv_root         = NULL;
8477     PL_xnv_arenaroot    = NULL;
8478     PL_xnv_root         = NULL;
8479     PL_xrv_arenaroot    = NULL;
8480     PL_xrv_root         = NULL;
8481     PL_xpv_arenaroot    = NULL;
8482     PL_xpv_root         = NULL;
8483     PL_xpviv_arenaroot  = NULL;
8484     PL_xpviv_root       = NULL;
8485     PL_xpvnv_arenaroot  = NULL;
8486     PL_xpvnv_root       = NULL;
8487     PL_xpvcv_arenaroot  = NULL;
8488     PL_xpvcv_root       = NULL;
8489     PL_xpvav_arenaroot  = NULL;
8490     PL_xpvav_root       = NULL;
8491     PL_xpvhv_arenaroot  = NULL;
8492     PL_xpvhv_root       = NULL;
8493     PL_xpvmg_arenaroot  = NULL;
8494     PL_xpvmg_root       = NULL;
8495     PL_xpvlv_arenaroot  = NULL;
8496     PL_xpvlv_root       = NULL;
8497     PL_xpvbm_arenaroot  = NULL;
8498     PL_xpvbm_root       = NULL;
8499     PL_he_arenaroot     = NULL;
8500     PL_he_root          = NULL;
8501     PL_nice_chunk       = NULL;
8502     PL_nice_chunk_size  = 0;
8503     PL_sv_count         = 0;
8504     PL_sv_objcount      = 0;
8505     PL_sv_root          = Nullsv;
8506     PL_sv_arenaroot     = Nullsv;
8507
8508     PL_debug            = proto_perl->Idebug;
8509
8510     /* create SV map for pointer relocation */
8511     PL_ptr_table = ptr_table_new();
8512
8513     /* initialize these special pointers as early as possible */
8514     SvANY(&PL_sv_undef)         = NULL;
8515     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
8516     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
8517     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8518
8519 #ifdef PERL_OBJECT
8520     SvUPGRADE(&PL_sv_no, SVt_PVNV);
8521 #else
8522     SvANY(&PL_sv_no)            = new_XPVNV();
8523 #endif
8524     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
8525     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8526     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
8527     SvCUR(&PL_sv_no)            = 0;
8528     SvLEN(&PL_sv_no)            = 1;
8529     SvNVX(&PL_sv_no)            = 0;
8530     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8531
8532 #ifdef PERL_OBJECT
8533     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8534 #else
8535     SvANY(&PL_sv_yes)           = new_XPVNV();
8536 #endif
8537     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
8538     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8539     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
8540     SvCUR(&PL_sv_yes)           = 1;
8541     SvLEN(&PL_sv_yes)           = 2;
8542     SvNVX(&PL_sv_yes)           = 1;
8543     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8544
8545     /* create shared string table */
8546     PL_strtab           = newHV();
8547     HvSHAREKEYS_off(PL_strtab);
8548     hv_ksplit(PL_strtab, 512);
8549     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8550
8551     PL_compiling                = proto_perl->Icompiling;
8552     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
8553     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
8554     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8555     if (!specialWARN(PL_compiling.cop_warnings))
8556         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8557     if (!specialCopIO(PL_compiling.cop_io))
8558         PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8559     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8560
8561     /* pseudo environmental stuff */
8562     PL_origargc         = proto_perl->Iorigargc;
8563     i = PL_origargc;
8564     New(0, PL_origargv, i+1, char*);
8565     PL_origargv[i] = '\0';
8566     while (i-- > 0) {
8567         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
8568     }
8569     PL_envgv            = gv_dup(proto_perl->Ienvgv);
8570     PL_incgv            = gv_dup(proto_perl->Iincgv);
8571     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
8572     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
8573     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
8574     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
8575
8576     /* switches */
8577     PL_minus_c          = proto_perl->Iminus_c;
8578     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
8579     PL_localpatches     = proto_perl->Ilocalpatches;
8580     PL_splitstr         = proto_perl->Isplitstr;
8581     PL_preprocess       = proto_perl->Ipreprocess;
8582     PL_minus_n          = proto_perl->Iminus_n;
8583     PL_minus_p          = proto_perl->Iminus_p;
8584     PL_minus_l          = proto_perl->Iminus_l;
8585     PL_minus_a          = proto_perl->Iminus_a;
8586     PL_minus_F          = proto_perl->Iminus_F;
8587     PL_doswitches       = proto_perl->Idoswitches;
8588     PL_dowarn           = proto_perl->Idowarn;
8589     PL_doextract        = proto_perl->Idoextract;
8590     PL_sawampersand     = proto_perl->Isawampersand;
8591     PL_unsafe           = proto_perl->Iunsafe;
8592     PL_inplace          = SAVEPV(proto_perl->Iinplace);
8593     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
8594     PL_perldb           = proto_perl->Iperldb;
8595     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8596
8597     /* magical thingies */
8598     /* XXX time(&PL_basetime) when asked for? */
8599     PL_basetime         = proto_perl->Ibasetime;
8600     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
8601
8602     PL_maxsysfd         = proto_perl->Imaxsysfd;
8603     PL_multiline        = proto_perl->Imultiline;
8604     PL_statusvalue      = proto_perl->Istatusvalue;
8605 #ifdef VMS
8606     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
8607 #endif
8608
8609     /* shortcuts to various I/O objects */
8610     PL_stdingv          = gv_dup(proto_perl->Istdingv);
8611     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
8612     PL_defgv            = gv_dup(proto_perl->Idefgv);
8613     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
8614     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
8615     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
8616
8617     /* shortcuts to regexp stuff */
8618     PL_replgv           = gv_dup(proto_perl->Ireplgv);
8619
8620     /* shortcuts to misc objects */
8621     PL_errgv            = gv_dup(proto_perl->Ierrgv);
8622
8623     /* shortcuts to debugging objects */
8624     PL_DBgv             = gv_dup(proto_perl->IDBgv);
8625     PL_DBline           = gv_dup(proto_perl->IDBline);
8626     PL_DBsub            = gv_dup(proto_perl->IDBsub);
8627     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
8628     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
8629     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
8630     PL_lineary          = av_dup(proto_perl->Ilineary);
8631     PL_dbargs           = av_dup(proto_perl->Idbargs);
8632
8633     /* symbol tables */
8634     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
8635     PL_curstash         = hv_dup(proto_perl->Tcurstash);
8636     PL_debstash         = hv_dup(proto_perl->Idebstash);
8637     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
8638     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
8639
8640     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
8641     PL_endav            = av_dup_inc(proto_perl->Iendav);
8642     PL_checkav          = av_dup_inc(proto_perl->Icheckav);
8643     PL_initav           = av_dup_inc(proto_perl->Iinitav);
8644
8645     PL_sub_generation   = proto_perl->Isub_generation;
8646
8647     /* funky return mechanisms */
8648     PL_forkprocess      = proto_perl->Iforkprocess;
8649
8650     /* subprocess state */
8651     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
8652
8653     /* internal state */
8654     PL_tainting         = proto_perl->Itainting;
8655     PL_maxo             = proto_perl->Imaxo;
8656     if (proto_perl->Iop_mask)
8657         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8658     else
8659         PL_op_mask      = Nullch;
8660
8661     /* current interpreter roots */
8662     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
8663     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
8664     PL_main_start       = proto_perl->Imain_start;
8665     PL_eval_root        = proto_perl->Ieval_root;
8666     PL_eval_start       = proto_perl->Ieval_start;
8667
8668     /* runtime control stuff */
8669     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8670     PL_copline          = proto_perl->Icopline;
8671
8672     PL_filemode         = proto_perl->Ifilemode;
8673     PL_lastfd           = proto_perl->Ilastfd;
8674     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
8675     PL_Argv             = NULL;
8676     PL_Cmd              = Nullch;
8677     PL_gensym           = proto_perl->Igensym;
8678     PL_preambled        = proto_perl->Ipreambled;
8679     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
8680     PL_laststatval      = proto_perl->Ilaststatval;
8681     PL_laststype        = proto_perl->Ilaststype;
8682     PL_mess_sv          = Nullsv;
8683
8684     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv);
8685     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
8686
8687     /* interpreter atexit processing */
8688     PL_exitlistlen      = proto_perl->Iexitlistlen;
8689     if (PL_exitlistlen) {
8690         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8691         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8692     }
8693     else
8694         PL_exitlist     = (PerlExitListEntry*)NULL;
8695     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
8696
8697     PL_profiledata      = NULL;
8698     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
8699     /* PL_rsfp_filters entries have fake IoDIRP() */
8700     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
8701
8702     PL_compcv                   = cv_dup(proto_perl->Icompcv);
8703     PL_comppad                  = av_dup(proto_perl->Icomppad);
8704     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
8705     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
8706     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
8707     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
8708                                                         proto_perl->Tcurpad);
8709
8710 #ifdef HAVE_INTERP_INTERN
8711     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8712 #endif
8713
8714     /* more statics moved here */
8715     PL_generation       = proto_perl->Igeneration;
8716     PL_DBcv             = cv_dup(proto_perl->IDBcv);
8717
8718     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
8719     PL_in_clean_all     = proto_perl->Iin_clean_all;
8720
8721     PL_uid              = proto_perl->Iuid;
8722     PL_euid             = proto_perl->Ieuid;
8723     PL_gid              = proto_perl->Igid;
8724     PL_egid             = proto_perl->Iegid;
8725     PL_nomemok          = proto_perl->Inomemok;
8726     PL_an               = proto_perl->Ian;
8727     PL_cop_seqmax       = proto_perl->Icop_seqmax;
8728     PL_op_seqmax        = proto_perl->Iop_seqmax;
8729     PL_evalseq          = proto_perl->Ievalseq;
8730     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
8731     PL_origalen         = proto_perl->Iorigalen;
8732     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
8733     PL_osname           = SAVEPV(proto_perl->Iosname);
8734     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
8735     PL_sighandlerp      = proto_perl->Isighandlerp;
8736
8737
8738     PL_runops           = proto_perl->Irunops;
8739
8740     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8741
8742 #ifdef CSH
8743     PL_cshlen           = proto_perl->Icshlen;
8744     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8745 #endif
8746
8747     PL_lex_state        = proto_perl->Ilex_state;
8748     PL_lex_defer        = proto_perl->Ilex_defer;
8749     PL_lex_expect       = proto_perl->Ilex_expect;
8750     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
8751     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
8752     PL_lex_starts       = proto_perl->Ilex_starts;
8753     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
8754     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
8755     PL_lex_op           = proto_perl->Ilex_op;
8756     PL_lex_inpat        = proto_perl->Ilex_inpat;
8757     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
8758     PL_lex_brackets     = proto_perl->Ilex_brackets;
8759     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8760     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
8761     PL_lex_casemods     = proto_perl->Ilex_casemods;
8762     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8763     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
8764
8765     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8766     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8767     PL_nexttoke         = proto_perl->Inexttoke;
8768
8769     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
8770     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8771     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8772     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8773     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8774     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8775     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8776     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8777     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8778     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8779     PL_pending_ident    = proto_perl->Ipending_ident;
8780     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
8781
8782     PL_expect           = proto_perl->Iexpect;
8783
8784     PL_multi_start      = proto_perl->Imulti_start;
8785     PL_multi_end        = proto_perl->Imulti_end;
8786     PL_multi_open       = proto_perl->Imulti_open;
8787     PL_multi_close      = proto_perl->Imulti_close;
8788
8789     PL_error_count      = proto_perl->Ierror_count;
8790     PL_subline          = proto_perl->Isubline;
8791     PL_subname          = sv_dup_inc(proto_perl->Isubname);
8792
8793     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
8794     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
8795     PL_padix                    = proto_perl->Ipadix;
8796     PL_padix_floor              = proto_perl->Ipadix_floor;
8797     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
8798
8799     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8800     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8801     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8802     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8803     PL_last_lop_op      = proto_perl->Ilast_lop_op;
8804     PL_in_my            = proto_perl->Iin_my;
8805     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
8806 #ifdef FCRYPT
8807     PL_cryptseen        = proto_perl->Icryptseen;
8808 #endif
8809
8810     PL_hints            = proto_perl->Ihints;
8811
8812     PL_amagic_generation        = proto_perl->Iamagic_generation;
8813
8814 #ifdef USE_LOCALE_COLLATE
8815     PL_collation_ix     = proto_perl->Icollation_ix;
8816     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
8817     PL_collation_standard       = proto_perl->Icollation_standard;
8818     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
8819     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
8820 #endif /* USE_LOCALE_COLLATE */
8821
8822 #ifdef USE_LOCALE_NUMERIC
8823     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
8824     PL_numeric_standard = proto_perl->Inumeric_standard;
8825     PL_numeric_local    = proto_perl->Inumeric_local;
8826     PL_numeric_radix    = proto_perl->Inumeric_radix;
8827 #endif /* !USE_LOCALE_NUMERIC */
8828
8829     /* utf8 character classes */
8830     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
8831     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
8832     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
8833     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
8834     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
8835     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
8836     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
8837     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
8838     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
8839     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
8840     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
8841     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
8842     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
8843     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
8844     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
8845     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
8846     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
8847
8848     /* swatch cache */
8849     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
8850     PL_last_swash_klen  = 0;
8851     PL_last_swash_key[0]= '\0';
8852     PL_last_swash_tmps  = (U8*)NULL;
8853     PL_last_swash_slen  = 0;
8854
8855     /* perly.c globals */
8856     PL_yydebug          = proto_perl->Iyydebug;
8857     PL_yynerrs          = proto_perl->Iyynerrs;
8858     PL_yyerrflag        = proto_perl->Iyyerrflag;
8859     PL_yychar           = proto_perl->Iyychar;
8860     PL_yyval            = proto_perl->Iyyval;
8861     PL_yylval           = proto_perl->Iyylval;
8862
8863     PL_glob_index       = proto_perl->Iglob_index;
8864     PL_srand_called     = proto_perl->Isrand_called;
8865     PL_uudmap['M']      = 0;            /* reinits on demand */
8866     PL_bitcount         = Nullch;       /* reinits on demand */
8867
8868     if (proto_perl->Ipsig_ptr) {
8869         int sig_num[] = { SIG_NUM };
8870         Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8871         Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8872         for (i = 1; PL_sig_name[i]; i++) {
8873             PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8874             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8875         }
8876     }
8877     else {
8878         PL_psig_ptr     = (SV**)NULL;
8879         PL_psig_name    = (SV**)NULL;
8880     }
8881
8882     /* thrdvar.h stuff */
8883
8884     if (flags & 1) {
8885         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8886         PL_tmps_ix              = proto_perl->Ttmps_ix;
8887         PL_tmps_max             = proto_perl->Ttmps_max;
8888         PL_tmps_floor           = proto_perl->Ttmps_floor;
8889         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8890         i = 0;
8891         while (i <= PL_tmps_ix) {
8892             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8893             ++i;
8894         }
8895
8896         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8897         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8898         Newz(54, PL_markstack, i, I32);
8899         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
8900                                                   - proto_perl->Tmarkstack);
8901         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
8902                                                   - proto_perl->Tmarkstack);
8903         Copy(proto_perl->Tmarkstack, PL_markstack,
8904              PL_markstack_ptr - PL_markstack + 1, I32);
8905
8906         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8907          * NOTE: unlike the others! */
8908         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
8909         PL_scopestack_max       = proto_perl->Tscopestack_max;
8910         Newz(54, PL_scopestack, PL_scopestack_max, I32);
8911         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8912
8913         /* next push_return() sets PL_retstack[PL_retstack_ix]
8914          * NOTE: unlike the others! */
8915         PL_retstack_ix          = proto_perl->Tretstack_ix;
8916         PL_retstack_max         = proto_perl->Tretstack_max;
8917         Newz(54, PL_retstack, PL_retstack_max, OP*);
8918         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8919
8920         /* NOTE: si_dup() looks at PL_markstack */
8921         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
8922
8923         /* PL_curstack          = PL_curstackinfo->si_stack; */
8924         PL_curstack             = av_dup(proto_perl->Tcurstack);
8925         PL_mainstack            = av_dup(proto_perl->Tmainstack);
8926
8927         /* next PUSHs() etc. set *(PL_stack_sp+1) */
8928         PL_stack_base           = AvARRAY(PL_curstack);
8929         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
8930                                                    - proto_perl->Tstack_base);
8931         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
8932
8933         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8934          * NOTE: unlike the others! */
8935         PL_savestack_ix         = proto_perl->Tsavestack_ix;
8936         PL_savestack_max        = proto_perl->Tsavestack_max;
8937         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8938         PL_savestack            = ss_dup(proto_perl);
8939     }
8940     else {
8941         init_stacks();
8942         ENTER;                  /* perl_destruct() wants to LEAVE; */
8943     }
8944
8945     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
8946     PL_top_env          = &PL_start_env;
8947
8948     PL_op               = proto_perl->Top;
8949
8950     PL_Sv               = Nullsv;
8951     PL_Xpv              = (XPV*)NULL;
8952     PL_na               = proto_perl->Tna;
8953
8954     PL_statbuf          = proto_perl->Tstatbuf;
8955     PL_statcache        = proto_perl->Tstatcache;
8956     PL_statgv           = gv_dup(proto_perl->Tstatgv);
8957     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
8958 #ifdef HAS_TIMES
8959     PL_timesbuf         = proto_perl->Ttimesbuf;
8960 #endif
8961
8962     PL_tainted          = proto_perl->Ttainted;
8963     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
8964     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
8965     PL_rs               = sv_dup_inc(proto_perl->Trs);
8966     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
8967     PL_ofs_sv           = sv_dup_inc(proto_perl->Tofs_sv);
8968     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
8969     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
8970     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
8971     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
8972     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
8973
8974     PL_restartop        = proto_perl->Trestartop;
8975     PL_in_eval          = proto_perl->Tin_eval;
8976     PL_delaymagic       = proto_perl->Tdelaymagic;
8977     PL_dirty            = proto_perl->Tdirty;
8978     PL_localizing       = proto_perl->Tlocalizing;
8979
8980 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8981     PL_protect          = proto_perl->Tprotect;
8982 #endif
8983     PL_errors           = sv_dup_inc(proto_perl->Terrors);
8984     PL_av_fetch_sv      = Nullsv;
8985     PL_hv_fetch_sv      = Nullsv;
8986     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
8987     PL_modcount         = proto_perl->Tmodcount;
8988     PL_lastgotoprobe    = Nullop;
8989     PL_dumpindent       = proto_perl->Tdumpindent;
8990
8991     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8992     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
8993     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
8994     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
8995     PL_sortcxix         = proto_perl->Tsortcxix;
8996     PL_efloatbuf        = Nullch;               /* reinits on demand */
8997     PL_efloatsize       = 0;                    /* reinits on demand */
8998
8999     /* regex stuff */
9000
9001     PL_screamfirst      = NULL;
9002     PL_screamnext       = NULL;
9003     PL_maxscream        = -1;                   /* reinits on demand */
9004     PL_lastscream       = Nullsv;
9005
9006     PL_watchaddr        = NULL;
9007     PL_watchok          = Nullch;
9008
9009     PL_regdummy         = proto_perl->Tregdummy;
9010     PL_regcomp_parse    = Nullch;
9011     PL_regxend          = Nullch;
9012     PL_regcode          = (regnode*)NULL;
9013     PL_regnaughty       = 0;
9014     PL_regsawback       = 0;
9015     PL_regprecomp       = Nullch;
9016     PL_regnpar          = 0;
9017     PL_regsize          = 0;
9018     PL_regflags         = 0;
9019     PL_regseen          = 0;
9020     PL_seen_zerolen     = 0;
9021     PL_seen_evals       = 0;
9022     PL_regcomp_rx       = (regexp*)NULL;
9023     PL_extralen         = 0;
9024     PL_colorset         = 0;            /* reinits PL_colors[] */
9025     /*PL_colors[6]      = {0,0,0,0,0,0};*/
9026     PL_reg_whilem_seen  = 0;
9027     PL_reginput         = Nullch;
9028     PL_regbol           = Nullch;
9029     PL_regeol           = Nullch;
9030     PL_regstartp        = (I32*)NULL;
9031     PL_regendp          = (I32*)NULL;
9032     PL_reglastparen     = (U32*)NULL;
9033     PL_regtill          = Nullch;
9034     PL_regprev          = '\n';
9035     PL_reg_start_tmp    = (char**)NULL;
9036     PL_reg_start_tmpl   = 0;
9037     PL_regdata          = (struct reg_data*)NULL;
9038     PL_bostr            = Nullch;
9039     PL_reg_flags        = 0;
9040     PL_reg_eval_set     = 0;
9041     PL_regnarrate       = 0;
9042     PL_regprogram       = (regnode*)NULL;
9043     PL_regindent        = 0;
9044     PL_regcc            = (CURCUR*)NULL;
9045     PL_reg_call_cc      = (struct re_cc_state*)NULL;
9046     PL_reg_re           = (regexp*)NULL;
9047     PL_reg_ganch        = Nullch;
9048     PL_reg_sv           = Nullsv;
9049     PL_reg_magic        = (MAGIC*)NULL;
9050     PL_reg_oldpos       = 0;
9051     PL_reg_oldcurpm     = (PMOP*)NULL;
9052     PL_reg_curpm        = (PMOP*)NULL;
9053     PL_reg_oldsaved     = Nullch;
9054     PL_reg_oldsavedlen  = 0;
9055     PL_reg_maxiter      = 0;
9056     PL_reg_leftiter     = 0;
9057     PL_reg_poscache     = Nullch;
9058     PL_reg_poscache_size= 0;
9059
9060     /* RE engine - function pointers */
9061     PL_regcompp         = proto_perl->Tregcompp;
9062     PL_regexecp         = proto_perl->Tregexecp;
9063     PL_regint_start     = proto_perl->Tregint_start;
9064     PL_regint_string    = proto_perl->Tregint_string;
9065     PL_regfree          = proto_perl->Tregfree;
9066
9067     PL_reginterp_cnt    = 0;
9068     PL_reg_starttry     = 0;
9069
9070 #ifdef PERL_OBJECT
9071     return (PerlInterpreter*)pPerl;
9072 #else
9073     return my_perl;
9074 #endif
9075 }
9076
9077 #else   /* !USE_ITHREADS */
9078
9079 #ifdef PERL_OBJECT
9080 #include "XSUB.h"
9081 #endif
9082
9083 #endif /* USE_ITHREADS */
9084
9085 static void
9086 do_report_used(pTHXo_ SV *sv)
9087 {
9088     if (SvTYPE(sv) != SVTYPEMASK) {
9089         PerlIO_printf(Perl_debug_log, "****\n");
9090         sv_dump(sv);
9091     }
9092 }
9093
9094 static void
9095 do_clean_objs(pTHXo_ SV *sv)
9096 {
9097     SV* rv;
9098
9099     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9100         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9101         if (SvWEAKREF(sv)) {
9102             sv_del_backref(sv);
9103             SvWEAKREF_off(sv);
9104             SvRV(sv) = 0;
9105         } else {
9106             SvROK_off(sv);
9107             SvRV(sv) = 0;
9108             SvREFCNT_dec(rv);
9109         }
9110     }
9111
9112     /* XXX Might want to check arrays, etc. */
9113 }
9114
9115 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9116 static void
9117 do_clean_named_objs(pTHXo_ SV *sv)
9118 {
9119     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9120         if ( SvOBJECT(GvSV(sv)) ||
9121              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9122              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9123              (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9124              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9125         {
9126             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9127             SvREFCNT_dec(sv);
9128         }
9129     }
9130 }
9131 #endif
9132
9133 static void
9134 do_clean_all(pTHXo_ SV *sv)
9135 {
9136     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9137     SvFLAGS(sv) |= SVf_BREAK;
9138     SvREFCNT_dec(sv);
9139 }
9140