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
2961         if (SvREADONLY(sv) && SvFAKE(sv)) {
2962             sv_force_normal(sv);
2963             s = SvPVX(sv);
2964         }
2965         len = SvCUR(sv) + 1; /* Plus the \0 */
2966         SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2967         SvCUR(sv) = len - 1;
2968         if (SvLEN(sv) != 0)
2969             Safefree(s); /* No longer using what was there before. */
2970         SvLEN(sv) = len; /* No longer know the real size. */
2971         SvUTF8_on(sv);
2972     }
2973 }
2974
2975 /*
2976 =for apidoc sv_utf8_downgrade
2977
2978 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2979 This may not be possible if the PV contains non-byte encoding characters;
2980 if this is the case, either returns false or, if C<fail_ok> is not
2981 true, croaks.
2982
2983 =cut
2984 */
2985
2986 bool
2987 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2988 {
2989     if (SvPOK(sv) && SvUTF8(sv)) {
2990         if (SvCUR(sv)) {
2991             char *s;
2992             STRLEN len;
2993
2994             if (SvREADONLY(sv) && SvFAKE(sv))
2995                 sv_force_normal(sv);
2996             s = SvPV(sv, len);
2997             if (!utf8_to_bytes((U8*)s, &len)) {
2998                 if (fail_ok)
2999                     return FALSE;
3000                 else {
3001                     if (PL_op)
3002                         Perl_croak(aTHX_ "Wide character in %s",
3003                                    PL_op_desc[PL_op->op_type]);
3004                     else
3005                         Perl_croak(aTHX_ "Wide character");
3006                 }
3007             }
3008             SvCUR(sv) = len;
3009         }
3010         SvUTF8_off(sv);
3011     }
3012
3013     return TRUE;
3014 }
3015
3016 /*
3017 =for apidoc sv_utf8_encode
3018
3019 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3020 flag so that it looks like bytes again. Nothing calls this.
3021
3022 =cut
3023 */
3024
3025 void
3026 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3027 {
3028     sv_utf8_upgrade(sv);
3029     SvUTF8_off(sv);
3030 }
3031
3032 bool
3033 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3034 {
3035     if (SvPOK(sv)) {
3036         char *c;
3037         char *e;
3038         bool has_utf = FALSE;
3039         if (!sv_utf8_downgrade(sv, TRUE))
3040             return FALSE;
3041
3042         /* it is actually just a matter of turning the utf8 flag on, but
3043          * we want to make sure everything inside is valid utf8 first.
3044          */
3045         c = SvPVX(sv);
3046         if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
3047             return FALSE;
3048         e = SvEND(sv);
3049         while (c < e) {
3050             if (UTF8_IS_CONTINUED(*c++)) {
3051                 SvUTF8_on(sv);
3052                 break;
3053             }
3054         }
3055     }
3056     return TRUE;
3057 }
3058
3059
3060 /* Note: sv_setsv() should not be called with a source string that needs
3061  * to be reused, since it may destroy the source string if it is marked
3062  * as temporary.
3063  */
3064
3065 /*
3066 =for apidoc sv_setsv
3067
3068 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3069 The source SV may be destroyed if it is mortal.  Does not handle 'set'
3070 magic.  See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3071 C<sv_setsv_mg>.
3072
3073 =cut
3074 */
3075
3076 void
3077 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3078 {
3079     register U32 sflags;
3080     register int dtype;
3081     register int stype;
3082
3083     if (sstr == dstr)
3084         return;
3085     SV_CHECK_THINKFIRST(dstr);
3086     if (!sstr)
3087         sstr = &PL_sv_undef;
3088     stype = SvTYPE(sstr);
3089     dtype = SvTYPE(dstr);
3090
3091     SvAMAGIC_off(dstr);
3092
3093     /* There's a lot of redundancy below but we're going for speed here */
3094
3095     switch (stype) {
3096     case SVt_NULL:
3097       undef_sstr:
3098         if (dtype != SVt_PVGV) {
3099             (void)SvOK_off(dstr);
3100             return;
3101         }
3102         break;
3103     case SVt_IV:
3104         if (SvIOK(sstr)) {
3105             switch (dtype) {
3106             case SVt_NULL:
3107                 sv_upgrade(dstr, SVt_IV);
3108                 break;
3109             case SVt_NV:
3110                 sv_upgrade(dstr, SVt_PVNV);
3111                 break;
3112             case SVt_RV:
3113             case SVt_PV:
3114                 sv_upgrade(dstr, SVt_PVIV);
3115                 break;
3116             }
3117             (void)SvIOK_only(dstr);
3118             SvIVX(dstr) = SvIVX(sstr);
3119             if (SvIsUV(sstr))
3120                 SvIsUV_on(dstr);
3121             if (SvTAINTED(sstr))
3122                 SvTAINT(dstr);
3123             return;
3124         }
3125         goto undef_sstr;
3126
3127     case SVt_NV:
3128         if (SvNOK(sstr)) {
3129             switch (dtype) {
3130             case SVt_NULL:
3131             case SVt_IV:
3132                 sv_upgrade(dstr, SVt_NV);
3133                 break;
3134             case SVt_RV:
3135             case SVt_PV:
3136             case SVt_PVIV:
3137                 sv_upgrade(dstr, SVt_PVNV);
3138                 break;
3139             }
3140             SvNVX(dstr) = SvNVX(sstr);
3141             (void)SvNOK_only(dstr);
3142             if (SvTAINTED(sstr))
3143                 SvTAINT(dstr);
3144             return;
3145         }
3146         goto undef_sstr;
3147
3148     case SVt_RV:
3149         if (dtype < SVt_RV)
3150             sv_upgrade(dstr, SVt_RV);
3151         else if (dtype == SVt_PVGV &&
3152                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3153             sstr = SvRV(sstr);
3154             if (sstr == dstr) {
3155                 if (GvIMPORTED(dstr) != GVf_IMPORTED
3156                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3157                 {
3158                     GvIMPORTED_on(dstr);
3159                 }
3160                 GvMULTI_on(dstr);
3161                 return;
3162             }
3163             goto glob_assign;
3164         }
3165         break;
3166     case SVt_PV:
3167     case SVt_PVFM:
3168         if (dtype < SVt_PV)
3169             sv_upgrade(dstr, SVt_PV);
3170         break;
3171     case SVt_PVIV:
3172         if (dtype < SVt_PVIV)
3173             sv_upgrade(dstr, SVt_PVIV);
3174         break;
3175     case SVt_PVNV:
3176         if (dtype < SVt_PVNV)
3177             sv_upgrade(dstr, SVt_PVNV);
3178         break;
3179     case SVt_PVAV:
3180     case SVt_PVHV:
3181     case SVt_PVCV:
3182     case SVt_PVIO:
3183         if (PL_op)
3184             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3185                 PL_op_name[PL_op->op_type]);
3186         else
3187             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3188         break;
3189
3190     case SVt_PVGV:
3191         if (dtype <= SVt_PVGV) {
3192   glob_assign:
3193             if (dtype != SVt_PVGV) {
3194                 char *name = GvNAME(sstr);
3195                 STRLEN len = GvNAMELEN(sstr);
3196                 sv_upgrade(dstr, SVt_PVGV);
3197                 sv_magic(dstr, dstr, '*', Nullch, 0);
3198                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3199                 GvNAME(dstr) = savepvn(name, len);
3200                 GvNAMELEN(dstr) = len;
3201                 SvFAKE_on(dstr);        /* can coerce to non-glob */
3202             }
3203             /* ahem, death to those who redefine active sort subs */
3204             else if (PL_curstackinfo->si_type == PERLSI_SORT
3205                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3206                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3207                       GvNAME(dstr));
3208             (void)SvOK_off(dstr);
3209             GvINTRO_off(dstr);          /* one-shot flag */
3210             gp_free((GV*)dstr);
3211             GvGP(dstr) = gp_ref(GvGP(sstr));
3212             if (SvTAINTED(sstr))
3213                 SvTAINT(dstr);
3214             if (GvIMPORTED(dstr) != GVf_IMPORTED
3215                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3216             {
3217                 GvIMPORTED_on(dstr);
3218             }
3219             GvMULTI_on(dstr);
3220             return;
3221         }
3222         /* FALL THROUGH */
3223
3224     default:
3225         if (SvGMAGICAL(sstr)) {
3226             mg_get(sstr);
3227             if (SvTYPE(sstr) != stype) {
3228                 stype = SvTYPE(sstr);
3229                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3230                     goto glob_assign;
3231             }
3232         }
3233         if (stype == SVt_PVLV)
3234             (void)SvUPGRADE(dstr, SVt_PVNV);
3235         else
3236             (void)SvUPGRADE(dstr, stype);
3237     }
3238
3239     sflags = SvFLAGS(sstr);
3240
3241     if (sflags & SVf_ROK) {
3242         if (dtype >= SVt_PV) {
3243             if (dtype == SVt_PVGV) {
3244                 SV *sref = SvREFCNT_inc(SvRV(sstr));
3245                 SV *dref = 0;
3246                 int intro = GvINTRO(dstr);
3247
3248                 if (intro) {
3249                     GP *gp;
3250                     gp_free((GV*)dstr);
3251                     GvINTRO_off(dstr);  /* one-shot flag */
3252                     Newz(602,gp, 1, GP);
3253                     GvGP(dstr) = gp_ref(gp);
3254                     GvSV(dstr) = NEWSV(72,0);
3255                     GvLINE(dstr) = CopLINE(PL_curcop);
3256                     GvEGV(dstr) = (GV*)dstr;
3257                 }
3258                 GvMULTI_on(dstr);
3259                 switch (SvTYPE(sref)) {
3260                 case SVt_PVAV:
3261                     if (intro)
3262                         SAVESPTR(GvAV(dstr));
3263                     else
3264                         dref = (SV*)GvAV(dstr);
3265                     GvAV(dstr) = (AV*)sref;
3266                     if (!GvIMPORTED_AV(dstr)
3267                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3268                     {
3269                         GvIMPORTED_AV_on(dstr);
3270                     }
3271                     break;
3272                 case SVt_PVHV:
3273                     if (intro)
3274                         SAVESPTR(GvHV(dstr));
3275                     else
3276                         dref = (SV*)GvHV(dstr);
3277                     GvHV(dstr) = (HV*)sref;
3278                     if (!GvIMPORTED_HV(dstr)
3279                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3280                     {
3281                         GvIMPORTED_HV_on(dstr);
3282                     }
3283                     break;
3284                 case SVt_PVCV:
3285                     if (intro) {
3286                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3287                             SvREFCNT_dec(GvCV(dstr));
3288                             GvCV(dstr) = Nullcv;
3289                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3290                             PL_sub_generation++;
3291                         }
3292                         SAVESPTR(GvCV(dstr));
3293                     }
3294                     else
3295                         dref = (SV*)GvCV(dstr);
3296                     if (GvCV(dstr) != (CV*)sref) {
3297                         CV* cv = GvCV(dstr);
3298                         if (cv) {
3299                             if (!GvCVGEN((GV*)dstr) &&
3300                                 (CvROOT(cv) || CvXSUB(cv)))
3301                             {
3302                                 SV *const_sv;
3303                                 /* ahem, death to those who redefine
3304                                  * active sort subs */
3305                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3306                                       PL_sortcop == CvSTART(cv))
3307                                     Perl_croak(aTHX_
3308                                     "Can't redefine active sort subroutine %s",
3309                                           GvENAME((GV*)dstr));
3310                                 /* Redefining a sub - warning is mandatory if
3311                                    it was a const and its value changed. */
3312                                 if (ckWARN(WARN_REDEFINE)
3313                                     || (CvCONST(cv)
3314                                         && (!CvCONST((CV*)sref)
3315                                             || sv_cmp(cv_const_sv(cv),
3316                                                       cv_const_sv((CV*)sref)))))
3317                                 {
3318                                     Perl_warner(aTHX_ WARN_REDEFINE,
3319                                         CvCONST(cv)
3320                                         ? "Constant subroutine %s redefined"
3321                                         : "Subroutine %s redefined",
3322                                         GvENAME((GV*)dstr));
3323                                 }
3324                             }
3325                             cv_ckproto(cv, (GV*)dstr,
3326                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
3327                         }
3328                         GvCV(dstr) = (CV*)sref;
3329                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3330                         GvASSUMECV_on(dstr);
3331                         PL_sub_generation++;
3332                     }
3333                     if (!GvIMPORTED_CV(dstr)
3334                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3335                     {
3336                         GvIMPORTED_CV_on(dstr);
3337                     }
3338                     break;
3339                 case SVt_PVIO:
3340                     if (intro)
3341                         SAVESPTR(GvIOp(dstr));
3342                     else
3343                         dref = (SV*)GvIOp(dstr);
3344                     GvIOp(dstr) = (IO*)sref;
3345                     break;
3346                 case SVt_PVFM:
3347                     if (intro)
3348                         SAVESPTR(GvFORM(dstr));
3349                     else
3350                         dref = (SV*)GvFORM(dstr);
3351                     GvFORM(dstr) = (CV*)sref;
3352                     break;
3353                 default:
3354                     if (intro)
3355                         SAVESPTR(GvSV(dstr));
3356                     else
3357                         dref = (SV*)GvSV(dstr);
3358                     GvSV(dstr) = sref;
3359                     if (!GvIMPORTED_SV(dstr)
3360                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3361                     {
3362                         GvIMPORTED_SV_on(dstr);
3363                     }
3364                     break;
3365                 }
3366                 if (dref)
3367                     SvREFCNT_dec(dref);
3368                 if (intro)
3369                     SAVEFREESV(sref);
3370                 if (SvTAINTED(sstr))
3371                     SvTAINT(dstr);
3372                 return;
3373             }
3374             if (SvPVX(dstr)) {
3375                 (void)SvOOK_off(dstr);          /* backoff */
3376                 if (SvLEN(dstr))
3377                     Safefree(SvPVX(dstr));
3378                 SvLEN(dstr)=SvCUR(dstr)=0;
3379             }
3380         }
3381         (void)SvOK_off(dstr);
3382         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3383         SvROK_on(dstr);
3384         if (sflags & SVp_NOK) {
3385             SvNOKp_on(dstr);
3386             /* Only set the public OK flag if the source has public OK.  */
3387             if (sflags & SVf_NOK)
3388                 SvFLAGS(dstr) |= SVf_NOK;
3389             SvNVX(dstr) = SvNVX(sstr);
3390         }
3391         if (sflags & SVp_IOK) {
3392             (void)SvIOKp_on(dstr);
3393             if (sflags & SVf_IOK)
3394                 SvFLAGS(dstr) |= SVf_IOK;
3395             if (sflags & SVf_IVisUV)
3396                 SvIsUV_on(dstr);
3397             SvIVX(dstr) = SvIVX(sstr);
3398         }
3399         if (SvAMAGIC(sstr)) {
3400             SvAMAGIC_on(dstr);
3401         }
3402     }
3403     else if (sflags & SVp_POK) {
3404
3405         /*
3406          * Check to see if we can just swipe the string.  If so, it's a
3407          * possible small lose on short strings, but a big win on long ones.
3408          * It might even be a win on short strings if SvPVX(dstr)
3409          * has to be allocated and SvPVX(sstr) has to be freed.
3410          */
3411
3412         if (SvTEMP(sstr) &&             /* slated for free anyway? */
3413             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
3414             !(sflags & SVf_OOK) &&      /* and not involved in OOK hack? */
3415             SvLEN(sstr)         &&      /* and really is a string */
3416             !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3417         {
3418             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
3419                 if (SvOOK(dstr)) {
3420                     SvFLAGS(dstr) &= ~SVf_OOK;
3421                     Safefree(SvPVX(dstr) - SvIVX(dstr));
3422                 }
3423                 else if (SvLEN(dstr))
3424                     Safefree(SvPVX(dstr));
3425             }
3426             (void)SvPOK_only(dstr);
3427             SvPV_set(dstr, SvPVX(sstr));
3428             SvLEN_set(dstr, SvLEN(sstr));
3429             SvCUR_set(dstr, SvCUR(sstr));
3430
3431             SvTEMP_off(dstr);
3432             (void)SvOK_off(sstr);               /* NOTE: nukes most SvFLAGS on sstr */
3433             SvPV_set(sstr, Nullch);
3434             SvLEN_set(sstr, 0);
3435             SvCUR_set(sstr, 0);
3436             SvTEMP_off(sstr);
3437         }
3438         else {                                  /* have to copy actual string */
3439             STRLEN len = SvCUR(sstr);
3440
3441             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
3442             Move(SvPVX(sstr),SvPVX(dstr),len,char);
3443             SvCUR_set(dstr, len);
3444             *SvEND(dstr) = '\0';
3445             (void)SvPOK_only(dstr);
3446         }
3447         if (sflags & SVf_UTF8)
3448             SvUTF8_on(dstr);
3449         /*SUPPRESS 560*/
3450         if (sflags & SVp_NOK) {
3451             SvNOKp_on(dstr);
3452             if (sflags & SVf_NOK)
3453                 SvFLAGS(dstr) |= SVf_NOK;
3454             SvNVX(dstr) = SvNVX(sstr);
3455         }
3456         if (sflags & SVp_IOK) {
3457             (void)SvIOKp_on(dstr);
3458             if (sflags & SVf_IOK)
3459                 SvFLAGS(dstr) |= SVf_IOK;
3460             if (sflags & SVf_IVisUV)
3461                 SvIsUV_on(dstr);
3462             SvIVX(dstr) = SvIVX(sstr);
3463         }
3464     }
3465     else if (sflags & SVp_IOK) {
3466         if (sflags & SVf_IOK)
3467             (void)SvIOK_only(dstr);
3468         else {
3469             SvOK_off(dstr);
3470             SvIOKp_on(dstr);
3471         }
3472         /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
3473         if (sflags & SVf_IVisUV)
3474             SvIsUV_on(dstr);
3475         SvIVX(dstr) = SvIVX(sstr);
3476         if (sflags & SVp_NOK) {
3477             if (sflags & SVf_NOK)
3478                 (void)SvNOK_on(dstr);
3479             else
3480                 (void)SvNOKp_on(dstr);
3481             SvNVX(dstr) = SvNVX(sstr);
3482         }
3483     }
3484     else if (sflags & SVp_NOK) {
3485         if (sflags & SVf_NOK)
3486             (void)SvNOK_only(dstr);
3487         else {
3488             SvOK_off(dstr);
3489             SvNOKp_on(dstr);
3490         }
3491         SvNVX(dstr) = SvNVX(sstr);
3492     }
3493     else {
3494         if (dtype == SVt_PVGV) {
3495             if (ckWARN(WARN_MISC))
3496                 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3497         }
3498         else
3499             (void)SvOK_off(dstr);
3500     }
3501     if (SvTAINTED(sstr))
3502         SvTAINT(dstr);
3503 }
3504
3505 /*
3506 =for apidoc sv_setsv_mg
3507
3508 Like C<sv_setsv>, but also handles 'set' magic.
3509
3510 =cut
3511 */
3512
3513 void
3514 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3515 {
3516     sv_setsv(dstr,sstr);
3517     SvSETMAGIC(dstr);
3518 }
3519
3520 /*
3521 =for apidoc sv_setpvn
3522
3523 Copies a string into an SV.  The C<len> parameter indicates the number of
3524 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
3525
3526 =cut
3527 */
3528
3529 void
3530 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3531 {
3532     register char *dptr;
3533
3534     SV_CHECK_THINKFIRST(sv);
3535     if (!ptr) {
3536         (void)SvOK_off(sv);
3537         return;
3538     }
3539     else {
3540         /* len is STRLEN which is unsigned, need to copy to signed */
3541         IV iv = len;
3542         assert(iv >= 0);
3543     }
3544     (void)SvUPGRADE(sv, SVt_PV);
3545
3546     SvGROW(sv, len + 1);
3547     dptr = SvPVX(sv);
3548     Move(ptr,dptr,len,char);
3549     dptr[len] = '\0';
3550     SvCUR_set(sv, len);
3551     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3552     SvTAINT(sv);
3553 }
3554
3555 /*
3556 =for apidoc sv_setpvn_mg
3557
3558 Like C<sv_setpvn>, but also handles 'set' magic.
3559
3560 =cut
3561 */
3562
3563 void
3564 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3565 {
3566     sv_setpvn(sv,ptr,len);
3567     SvSETMAGIC(sv);
3568 }
3569
3570 /*
3571 =for apidoc sv_setpv
3572
3573 Copies a string into an SV.  The string must be null-terminated.  Does not
3574 handle 'set' magic.  See C<sv_setpv_mg>.
3575
3576 =cut
3577 */
3578
3579 void
3580 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3581 {
3582     register STRLEN len;
3583
3584     SV_CHECK_THINKFIRST(sv);
3585     if (!ptr) {
3586         (void)SvOK_off(sv);
3587         return;
3588     }
3589     len = strlen(ptr);
3590     (void)SvUPGRADE(sv, SVt_PV);
3591
3592     SvGROW(sv, len + 1);
3593     Move(ptr,SvPVX(sv),len+1,char);
3594     SvCUR_set(sv, len);
3595     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3596     SvTAINT(sv);
3597 }
3598
3599 /*
3600 =for apidoc sv_setpv_mg
3601
3602 Like C<sv_setpv>, but also handles 'set' magic.
3603
3604 =cut
3605 */
3606
3607 void
3608 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3609 {
3610     sv_setpv(sv,ptr);
3611     SvSETMAGIC(sv);
3612 }
3613
3614 /*
3615 =for apidoc sv_usepvn
3616
3617 Tells an SV to use C<ptr> to find its string value.  Normally the string is
3618 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3619 The C<ptr> should point to memory that was allocated by C<malloc>.  The
3620 string length, C<len>, must be supplied.  This function will realloc the
3621 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3622 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
3623 See C<sv_usepvn_mg>.
3624
3625 =cut
3626 */
3627
3628 void
3629 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3630 {
3631     SV_CHECK_THINKFIRST(sv);
3632     (void)SvUPGRADE(sv, SVt_PV);
3633     if (!ptr) {
3634         (void)SvOK_off(sv);
3635         return;
3636     }
3637     (void)SvOOK_off(sv);
3638     if (SvPVX(sv) && SvLEN(sv))
3639         Safefree(SvPVX(sv));
3640     Renew(ptr, len+1, char);
3641     SvPVX(sv) = ptr;
3642     SvCUR_set(sv, len);
3643     SvLEN_set(sv, len+1);
3644     *SvEND(sv) = '\0';
3645     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3646     SvTAINT(sv);
3647 }
3648
3649 /*
3650 =for apidoc sv_usepvn_mg
3651
3652 Like C<sv_usepvn>, but also handles 'set' magic.
3653
3654 =cut
3655 */
3656
3657 void
3658 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3659 {
3660     sv_usepvn(sv,ptr,len);
3661     SvSETMAGIC(sv);
3662 }
3663
3664 void
3665 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3666 {
3667     if (SvREADONLY(sv)) {
3668         if (SvFAKE(sv)) {
3669             char *pvx = SvPVX(sv);
3670             STRLEN len = SvCUR(sv);
3671             U32 hash   = SvUVX(sv);
3672             SvGROW(sv, len + 1);
3673             Move(pvx,SvPVX(sv),len,char);
3674             *SvEND(sv) = '\0';
3675             SvFAKE_off(sv);
3676             SvREADONLY_off(sv);
3677             unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3678         }
3679         else if (PL_curcop != &PL_compiling)
3680             Perl_croak(aTHX_ PL_no_modify);
3681     }
3682     if (SvROK(sv))
3683         sv_unref_flags(sv, flags);
3684     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3685         sv_unglob(sv);
3686 }
3687
3688 void
3689 Perl_sv_force_normal(pTHX_ register SV *sv)
3690 {
3691     sv_force_normal_flags(sv, 0);
3692 }
3693
3694 /*
3695 =for apidoc sv_chop
3696
3697 Efficient removal of characters from the beginning of the string buffer.
3698 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3699 the string buffer.  The C<ptr> becomes the first character of the adjusted
3700 string.
3701
3702 =cut
3703 */
3704
3705 void
3706 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3707
3708
3709 {
3710     register STRLEN delta;
3711
3712     if (!ptr || !SvPOKp(sv))
3713         return;
3714     SV_CHECK_THINKFIRST(sv);
3715     if (SvTYPE(sv) < SVt_PVIV)
3716         sv_upgrade(sv,SVt_PVIV);
3717
3718     if (!SvOOK(sv)) {
3719         if (!SvLEN(sv)) { /* make copy of shared string */
3720             char *pvx = SvPVX(sv);
3721             STRLEN len = SvCUR(sv);
3722             SvGROW(sv, len + 1);
3723             Move(pvx,SvPVX(sv),len,char);
3724             *SvEND(sv) = '\0';
3725         }
3726         SvIVX(sv) = 0;
3727         SvFLAGS(sv) |= SVf_OOK;
3728     }
3729     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3730     delta = ptr - SvPVX(sv);
3731     SvLEN(sv) -= delta;
3732     SvCUR(sv) -= delta;
3733     SvPVX(sv) += delta;
3734     SvIVX(sv) += delta;
3735 }
3736
3737 /*
3738 =for apidoc sv_catpvn
3739
3740 Concatenates the string onto the end of the string which is in the SV.  The
3741 C<len> indicates number of bytes to copy.  Handles 'get' magic, but not
3742 'set' magic.  See C<sv_catpvn_mg>.
3743
3744 =cut
3745 */
3746
3747 void
3748 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3749 {
3750     STRLEN tlen;
3751     char *junk;
3752
3753     junk = SvPV_force(sv, tlen);
3754     SvGROW(sv, tlen + len + 1);
3755     if (ptr == junk)
3756         ptr = SvPVX(sv);
3757     Move(ptr,SvPVX(sv)+tlen,len,char);
3758     SvCUR(sv) += len;
3759     *SvEND(sv) = '\0';
3760     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3761     SvTAINT(sv);
3762 }
3763
3764 /*
3765 =for apidoc sv_catpvn_mg
3766
3767 Like C<sv_catpvn>, but also handles 'set' magic.
3768
3769 =cut
3770 */
3771
3772 void
3773 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3774 {
3775     sv_catpvn(sv,ptr,len);
3776     SvSETMAGIC(sv);
3777 }
3778
3779 /*
3780 =for apidoc sv_catsv
3781
3782 Concatenates the string from SV C<ssv> onto the end of the string in
3783 SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
3784 not 'set' magic.  See C<sv_catsv_mg>.
3785
3786 =cut */
3787
3788 void
3789 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3790 {
3791     char *spv;
3792     STRLEN slen;
3793     if (!ssv)
3794         return;
3795     if ((spv = SvPV(ssv, slen))) {
3796         bool dutf8 = DO_UTF8(dsv);
3797         bool sutf8 = DO_UTF8(ssv);
3798
3799         if (dutf8 == sutf8)
3800             sv_catpvn(dsv,spv,slen);
3801         else {
3802             if (dutf8) {
3803                 /* Not modifying source SV, so taking a temporary copy. */
3804                 SV* csv = sv_2mortal(newSVsv(ssv));
3805                 char *cpv;
3806                 STRLEN clen;
3807
3808                 sv_utf8_upgrade(csv);
3809                 cpv = SvPV(csv,clen);
3810                 sv_catpvn(dsv,cpv,clen);
3811             }
3812             else {
3813                 sv_utf8_upgrade(dsv);
3814                 sv_catpvn(dsv,spv,slen);
3815                 SvUTF8_on(dsv); /* If dsv has no wide characters. */
3816             }
3817         }
3818     }
3819 }
3820
3821 /*
3822 =for apidoc sv_catsv_mg
3823
3824 Like C<sv_catsv>, but also handles 'set' magic.
3825
3826 =cut
3827 */
3828
3829 void
3830 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3831 {
3832     sv_catsv(dsv,ssv);
3833     SvSETMAGIC(dsv);
3834 }
3835
3836 /*
3837 =for apidoc sv_catpv
3838
3839 Concatenates the string onto the end of the string which is in the SV.
3840 Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
3841
3842 =cut
3843 */
3844
3845 void
3846 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3847 {
3848     register STRLEN len;
3849     STRLEN tlen;
3850     char *junk;
3851
3852     if (!ptr)
3853         return;
3854     junk = SvPV_force(sv, tlen);
3855     len = strlen(ptr);
3856     SvGROW(sv, tlen + len + 1);
3857     if (ptr == junk)
3858         ptr = SvPVX(sv);
3859     Move(ptr,SvPVX(sv)+tlen,len+1,char);
3860     SvCUR(sv) += len;
3861     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3862     SvTAINT(sv);
3863 }
3864
3865 /*
3866 =for apidoc sv_catpv_mg
3867
3868 Like C<sv_catpv>, but also handles 'set' magic.
3869
3870 =cut
3871 */
3872
3873 void
3874 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3875 {
3876     sv_catpv(sv,ptr);
3877     SvSETMAGIC(sv);
3878 }
3879
3880 SV *
3881 Perl_newSV(pTHX_ STRLEN len)
3882 {
3883     register SV *sv;
3884
3885     new_SV(sv);
3886     if (len) {
3887         sv_upgrade(sv, SVt_PV);
3888         SvGROW(sv, len + 1);
3889     }
3890     return sv;
3891 }
3892
3893 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3894
3895 /*
3896 =for apidoc sv_magic
3897
3898 Adds magic to an SV.
3899
3900 =cut
3901 */
3902
3903 void
3904 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3905 {
3906     MAGIC* mg;
3907
3908     if (SvREADONLY(sv)) {
3909         if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3910             Perl_croak(aTHX_ PL_no_modify);
3911     }
3912     if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3913         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3914             if (how == 't')
3915                 mg->mg_len |= 1;
3916             return;
3917         }
3918     }
3919     else {
3920         (void)SvUPGRADE(sv, SVt_PVMG);
3921     }
3922     Newz(702,mg, 1, MAGIC);
3923     mg->mg_moremagic = SvMAGIC(sv);
3924
3925     SvMAGIC(sv) = mg;
3926     if (!obj || obj == sv || how == '#' || how == 'r')
3927         mg->mg_obj = obj;
3928     else {
3929         mg->mg_obj = SvREFCNT_inc(obj);
3930         mg->mg_flags |= MGf_REFCOUNTED;
3931     }
3932     mg->mg_type = how;
3933     mg->mg_len = namlen;
3934     if (name)
3935         if (namlen >= 0)
3936             mg->mg_ptr = savepvn(name, namlen);
3937         else if (namlen == HEf_SVKEY)
3938             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3939
3940     switch (how) {
3941     case 0:
3942         mg->mg_virtual = &PL_vtbl_sv;
3943         break;
3944     case 'A':
3945         mg->mg_virtual = &PL_vtbl_amagic;
3946         break;
3947     case 'a':
3948         mg->mg_virtual = &PL_vtbl_amagicelem;
3949         break;
3950     case 'c':
3951         mg->mg_virtual = &PL_vtbl_ovrld;
3952         break;
3953     case 'B':
3954         mg->mg_virtual = &PL_vtbl_bm;
3955         break;
3956     case 'D':
3957         mg->mg_virtual = &PL_vtbl_regdata;
3958         break;
3959     case 'd':
3960         mg->mg_virtual = &PL_vtbl_regdatum;
3961         break;
3962     case 'E':
3963         mg->mg_virtual = &PL_vtbl_env;
3964         break;
3965     case 'f':
3966         mg->mg_virtual = &PL_vtbl_fm;
3967         break;
3968     case 'e':
3969         mg->mg_virtual = &PL_vtbl_envelem;
3970         break;
3971     case 'g':
3972         mg->mg_virtual = &PL_vtbl_mglob;
3973         break;
3974     case 'I':
3975         mg->mg_virtual = &PL_vtbl_isa;
3976         break;
3977     case 'i':
3978         mg->mg_virtual = &PL_vtbl_isaelem;
3979         break;
3980     case 'k':
3981         mg->mg_virtual = &PL_vtbl_nkeys;
3982         break;
3983     case 'L':
3984         SvRMAGICAL_on(sv);
3985         mg->mg_virtual = 0;
3986         break;
3987     case 'l':
3988         mg->mg_virtual = &PL_vtbl_dbline;
3989         break;
3990 #ifdef USE_THREADS
3991     case 'm':
3992         mg->mg_virtual = &PL_vtbl_mutex;
3993         break;
3994 #endif /* USE_THREADS */
3995 #ifdef USE_LOCALE_COLLATE
3996     case 'o':
3997         mg->mg_virtual = &PL_vtbl_collxfrm;
3998         break;
3999 #endif /* USE_LOCALE_COLLATE */
4000     case 'P':
4001         mg->mg_virtual = &PL_vtbl_pack;
4002         break;
4003     case 'p':
4004     case 'q':
4005         mg->mg_virtual = &PL_vtbl_packelem;
4006         break;
4007     case 'r':
4008         mg->mg_virtual = &PL_vtbl_regexp;
4009         break;
4010     case 'S':
4011         mg->mg_virtual = &PL_vtbl_sig;
4012         break;
4013     case 's':
4014         mg->mg_virtual = &PL_vtbl_sigelem;
4015         break;
4016     case 't':
4017         mg->mg_virtual = &PL_vtbl_taint;
4018         mg->mg_len = 1;
4019         break;
4020     case 'U':
4021         mg->mg_virtual = &PL_vtbl_uvar;
4022         break;
4023     case 'v':
4024         mg->mg_virtual = &PL_vtbl_vec;
4025         break;
4026     case 'x':
4027         mg->mg_virtual = &PL_vtbl_substr;
4028         break;
4029     case 'y':
4030         mg->mg_virtual = &PL_vtbl_defelem;
4031         break;
4032     case '*':
4033         mg->mg_virtual = &PL_vtbl_glob;
4034         break;
4035     case '#':
4036         mg->mg_virtual = &PL_vtbl_arylen;
4037         break;
4038     case '.':
4039         mg->mg_virtual = &PL_vtbl_pos;
4040         break;
4041     case '<':
4042         mg->mg_virtual = &PL_vtbl_backref;
4043         break;
4044     case '~':   /* Reserved for use by extensions not perl internals.   */
4045         /* Useful for attaching extension internal data to perl vars.   */
4046         /* Note that multiple extensions may clash if magical scalars   */
4047         /* etc holding private data from one are passed to another.     */
4048         SvRMAGICAL_on(sv);
4049         break;
4050     default:
4051         Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4052     }
4053     mg_magical(sv);
4054     if (SvGMAGICAL(sv))
4055         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4056 }
4057
4058 /*
4059 =for apidoc sv_unmagic
4060
4061 Removes magic from an SV.
4062
4063 =cut
4064 */
4065
4066 int
4067 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4068 {
4069     MAGIC* mg;
4070     MAGIC** mgp;
4071     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4072         return 0;
4073     mgp = &SvMAGIC(sv);
4074     for (mg = *mgp; mg; mg = *mgp) {
4075         if (mg->mg_type == type) {
4076             MGVTBL* vtbl = mg->mg_virtual;
4077             *mgp = mg->mg_moremagic;
4078             if (vtbl && vtbl->svt_free)
4079                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4080             if (mg->mg_ptr && mg->mg_type != 'g')
4081                 if (mg->mg_len >= 0)
4082                     Safefree(mg->mg_ptr);
4083                 else if (mg->mg_len == HEf_SVKEY)
4084                     SvREFCNT_dec((SV*)mg->mg_ptr);
4085             if (mg->mg_flags & MGf_REFCOUNTED)
4086                 SvREFCNT_dec(mg->mg_obj);
4087             Safefree(mg);
4088         }
4089         else
4090             mgp = &mg->mg_moremagic;
4091     }
4092     if (!SvMAGIC(sv)) {
4093         SvMAGICAL_off(sv);
4094         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4095     }
4096
4097     return 0;
4098 }
4099
4100 /*
4101 =for apidoc sv_rvweaken
4102
4103 Weaken a reference.
4104
4105 =cut
4106 */
4107
4108 SV *
4109 Perl_sv_rvweaken(pTHX_ SV *sv)
4110 {
4111     SV *tsv;
4112     if (!SvOK(sv))  /* let undefs pass */
4113         return sv;
4114     if (!SvROK(sv))
4115         Perl_croak(aTHX_ "Can't weaken a nonreference");
4116     else if (SvWEAKREF(sv)) {
4117         if (ckWARN(WARN_MISC))
4118             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4119         return sv;
4120     }
4121     tsv = SvRV(sv);
4122     sv_add_backref(tsv, sv);
4123     SvWEAKREF_on(sv);
4124     SvREFCNT_dec(tsv);
4125     return sv;
4126 }
4127
4128 STATIC void
4129 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4130 {
4131     AV *av;
4132     MAGIC *mg;
4133     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4134         av = (AV*)mg->mg_obj;
4135     else {
4136         av = newAV();
4137         sv_magic(tsv, (SV*)av, '<', NULL, 0);
4138         SvREFCNT_dec(av);           /* for sv_magic */
4139     }
4140     av_push(av,sv);
4141 }
4142
4143 STATIC void
4144 S_sv_del_backref(pTHX_ SV *sv)
4145 {
4146     AV *av;
4147     SV **svp;
4148     I32 i;
4149     SV *tsv = SvRV(sv);
4150     MAGIC *mg;
4151     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4152         Perl_croak(aTHX_ "panic: del_backref");
4153     av = (AV *)mg->mg_obj;
4154     svp = AvARRAY(av);
4155     i = AvFILLp(av);
4156     while (i >= 0) {
4157         if (svp[i] == sv) {
4158             svp[i] = &PL_sv_undef; /* XXX */
4159         }
4160         i--;
4161     }
4162 }
4163
4164 /*
4165 =for apidoc sv_insert
4166
4167 Inserts a string at the specified offset/length within the SV. Similar to
4168 the Perl substr() function.
4169
4170 =cut
4171 */
4172
4173 void
4174 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4175 {
4176     register char *big;
4177     register char *mid;
4178     register char *midend;
4179     register char *bigend;
4180     register I32 i;
4181     STRLEN curlen;
4182
4183
4184     if (!bigstr)
4185         Perl_croak(aTHX_ "Can't modify non-existent substring");
4186     SvPV_force(bigstr, curlen);
4187     (void)SvPOK_only_UTF8(bigstr);
4188     if (offset + len > curlen) {
4189         SvGROW(bigstr, offset+len+1);
4190         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4191         SvCUR_set(bigstr, offset+len);
4192     }
4193
4194     SvTAINT(bigstr);
4195     i = littlelen - len;
4196     if (i > 0) {                        /* string might grow */
4197         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4198         mid = big + offset + len;
4199         midend = bigend = big + SvCUR(bigstr);
4200         bigend += i;
4201         *bigend = '\0';
4202         while (midend > mid)            /* shove everything down */
4203             *--bigend = *--midend;
4204         Move(little,big+offset,littlelen,char);
4205         SvCUR(bigstr) += i;
4206         SvSETMAGIC(bigstr);
4207         return;
4208     }
4209     else if (i == 0) {
4210         Move(little,SvPVX(bigstr)+offset,len,char);
4211         SvSETMAGIC(bigstr);
4212         return;
4213     }
4214
4215     big = SvPVX(bigstr);
4216     mid = big + offset;
4217     midend = mid + len;
4218     bigend = big + SvCUR(bigstr);
4219
4220     if (midend > bigend)
4221         Perl_croak(aTHX_ "panic: sv_insert");
4222
4223     if (mid - big > bigend - midend) {  /* faster to shorten from end */
4224         if (littlelen) {
4225             Move(little, mid, littlelen,char);
4226             mid += littlelen;
4227         }
4228         i = bigend - midend;
4229         if (i > 0) {
4230             Move(midend, mid, i,char);
4231             mid += i;
4232         }
4233         *mid = '\0';
4234         SvCUR_set(bigstr, mid - big);
4235     }
4236     /*SUPPRESS 560*/
4237     else if ((i = mid - big)) { /* faster from front */
4238         midend -= littlelen;
4239         mid = midend;
4240         sv_chop(bigstr,midend-i);
4241         big += i;
4242         while (i--)
4243             *--midend = *--big;
4244         if (littlelen)
4245             Move(little, mid, littlelen,char);
4246     }
4247     else if (littlelen) {
4248         midend -= littlelen;
4249         sv_chop(bigstr,midend);
4250         Move(little,midend,littlelen,char);
4251     }
4252     else {
4253         sv_chop(bigstr,midend);
4254     }
4255     SvSETMAGIC(bigstr);
4256 }
4257
4258 /*
4259 =for apidoc sv_replace
4260
4261 Make the first argument a copy of the second, then delete the original.
4262
4263 =cut
4264 */
4265
4266 void
4267 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4268 {
4269     U32 refcnt = SvREFCNT(sv);
4270     SV_CHECK_THINKFIRST(sv);
4271     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4272         Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4273     if (SvMAGICAL(sv)) {
4274         if (SvMAGICAL(nsv))
4275             mg_free(nsv);
4276         else
4277             sv_upgrade(nsv, SVt_PVMG);
4278         SvMAGIC(nsv) = SvMAGIC(sv);
4279         SvFLAGS(nsv) |= SvMAGICAL(sv);
4280         SvMAGICAL_off(sv);
4281         SvMAGIC(sv) = 0;
4282     }
4283     SvREFCNT(sv) = 0;
4284     sv_clear(sv);
4285     assert(!SvREFCNT(sv));
4286     StructCopy(nsv,sv,SV);
4287     SvREFCNT(sv) = refcnt;
4288     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
4289     del_SV(nsv);
4290 }
4291
4292 /*
4293 =for apidoc sv_clear
4294
4295 Clear an SV, making it empty. Does not free the memory used by the SV
4296 itself.
4297
4298 =cut
4299 */
4300
4301 void
4302 Perl_sv_clear(pTHX_ register SV *sv)
4303 {
4304     HV* stash;
4305     assert(sv);
4306     assert(SvREFCNT(sv) == 0);
4307
4308     if (SvOBJECT(sv)) {
4309         if (PL_defstash) {              /* Still have a symbol table? */
4310             djSP;
4311             CV* destructor;
4312             SV tmpref;
4313
4314             Zero(&tmpref, 1, SV);
4315             sv_upgrade(&tmpref, SVt_RV);
4316             SvROK_on(&tmpref);
4317             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
4318             SvREFCNT(&tmpref) = 1;
4319
4320             do {
4321                 stash = SvSTASH(sv);
4322                 destructor = StashHANDLER(stash,DESTROY);
4323                 if (destructor) {
4324                     ENTER;
4325                     PUSHSTACKi(PERLSI_DESTROY);
4326                     SvRV(&tmpref) = SvREFCNT_inc(sv);
4327                     EXTEND(SP, 2);
4328                     PUSHMARK(SP);
4329                     PUSHs(&tmpref);
4330                     PUTBACK;
4331                     call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4332                     SvREFCNT(sv)--;
4333                     POPSTACK;
4334                     SPAGAIN;
4335                     LEAVE;
4336                 }
4337             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4338
4339             del_XRV(SvANY(&tmpref));
4340
4341             if (SvREFCNT(sv)) {
4342                 if (PL_in_clean_objs)
4343                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4344                           HvNAME(stash));
4345                 /* DESTROY gave object new lease on life */
4346                 return;
4347             }
4348         }
4349
4350         if (SvOBJECT(sv)) {
4351             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
4352             SvOBJECT_off(sv);   /* Curse the object. */
4353             if (SvTYPE(sv) != SVt_PVIO)
4354                 --PL_sv_objcount;       /* XXX Might want something more general */
4355         }
4356     }
4357     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4358         mg_free(sv);
4359     stash = NULL;
4360     switch (SvTYPE(sv)) {
4361     case SVt_PVIO:
4362         if (IoIFP(sv) &&
4363             IoIFP(sv) != PerlIO_stdin() &&
4364             IoIFP(sv) != PerlIO_stdout() &&
4365             IoIFP(sv) != PerlIO_stderr())
4366         {
4367             io_close((IO*)sv, FALSE);
4368         }
4369         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4370             PerlDir_close(IoDIRP(sv));
4371         IoDIRP(sv) = (DIR*)NULL;
4372         Safefree(IoTOP_NAME(sv));
4373         Safefree(IoFMT_NAME(sv));
4374         Safefree(IoBOTTOM_NAME(sv));
4375         /* FALL THROUGH */
4376     case SVt_PVBM:
4377         goto freescalar;
4378     case SVt_PVCV:
4379     case SVt_PVFM:
4380         cv_undef((CV*)sv);
4381         goto freescalar;
4382     case SVt_PVHV:
4383         hv_undef((HV*)sv);
4384         break;
4385     case SVt_PVAV:
4386         av_undef((AV*)sv);
4387         break;
4388     case SVt_PVLV:
4389         SvREFCNT_dec(LvTARG(sv));
4390         goto freescalar;
4391     case SVt_PVGV:
4392         gp_free((GV*)sv);
4393         Safefree(GvNAME(sv));
4394         /* cannot decrease stash refcount yet, as we might recursively delete
4395            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4396            of stash until current sv is completely gone.
4397            -- JohnPC, 27 Mar 1998 */
4398         stash = GvSTASH(sv);
4399         /* FALL THROUGH */
4400     case SVt_PVMG:
4401     case SVt_PVNV:
4402     case SVt_PVIV:
4403       freescalar:
4404         (void)SvOOK_off(sv);
4405         /* FALL THROUGH */
4406     case SVt_PV:
4407     case SVt_RV:
4408         if (SvROK(sv)) {
4409             if (SvWEAKREF(sv))
4410                 sv_del_backref(sv);
4411             else
4412                 SvREFCNT_dec(SvRV(sv));
4413         }
4414         else if (SvPVX(sv) && SvLEN(sv))
4415             Safefree(SvPVX(sv));
4416         else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4417             unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4418             SvFAKE_off(sv);
4419         }
4420         break;
4421 /*
4422     case SVt_NV:
4423     case SVt_IV:
4424     case SVt_NULL:
4425         break;
4426 */
4427     }
4428
4429     switch (SvTYPE(sv)) {
4430     case SVt_NULL:
4431         break;
4432     case SVt_IV:
4433         del_XIV(SvANY(sv));
4434         break;
4435     case SVt_NV:
4436         del_XNV(SvANY(sv));
4437         break;
4438     case SVt_RV:
4439         del_XRV(SvANY(sv));
4440         break;
4441     case SVt_PV:
4442         del_XPV(SvANY(sv));
4443         break;
4444     case SVt_PVIV:
4445         del_XPVIV(SvANY(sv));
4446         break;
4447     case SVt_PVNV:
4448         del_XPVNV(SvANY(sv));
4449         break;
4450     case SVt_PVMG:
4451         del_XPVMG(SvANY(sv));
4452         break;
4453     case SVt_PVLV:
4454         del_XPVLV(SvANY(sv));
4455         break;
4456     case SVt_PVAV:
4457         del_XPVAV(SvANY(sv));
4458         break;
4459     case SVt_PVHV:
4460         del_XPVHV(SvANY(sv));
4461         break;
4462     case SVt_PVCV:
4463         del_XPVCV(SvANY(sv));
4464         break;
4465     case SVt_PVGV:
4466         del_XPVGV(SvANY(sv));
4467         /* code duplication for increased performance. */
4468         SvFLAGS(sv) &= SVf_BREAK;
4469         SvFLAGS(sv) |= SVTYPEMASK;
4470         /* decrease refcount of the stash that owns this GV, if any */
4471         if (stash)
4472             SvREFCNT_dec(stash);
4473         return; /* not break, SvFLAGS reset already happened */
4474     case SVt_PVBM:
4475         del_XPVBM(SvANY(sv));
4476         break;
4477     case SVt_PVFM:
4478         del_XPVFM(SvANY(sv));
4479         break;
4480     case SVt_PVIO:
4481         del_XPVIO(SvANY(sv));
4482         break;
4483     }
4484     SvFLAGS(sv) &= SVf_BREAK;
4485     SvFLAGS(sv) |= SVTYPEMASK;
4486 }
4487
4488 SV *
4489 Perl_sv_newref(pTHX_ SV *sv)
4490 {
4491     if (sv)
4492         ATOMIC_INC(SvREFCNT(sv));
4493     return sv;
4494 }
4495
4496 /*
4497 =for apidoc sv_free
4498
4499 Free the memory used by an SV.
4500
4501 =cut
4502 */
4503
4504 void
4505 Perl_sv_free(pTHX_ SV *sv)
4506 {
4507     int refcount_is_zero;
4508
4509     if (!sv)
4510         return;
4511     if (SvREFCNT(sv) == 0) {
4512         if (SvFLAGS(sv) & SVf_BREAK)
4513             return;
4514         if (PL_in_clean_all) /* All is fair */
4515             return;
4516         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4517             /* make sure SvREFCNT(sv)==0 happens very seldom */
4518             SvREFCNT(sv) = (~(U32)0)/2;
4519             return;
4520         }
4521         if (ckWARN_d(WARN_INTERNAL))
4522             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4523         return;
4524     }
4525     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4526     if (!refcount_is_zero)
4527         return;
4528 #ifdef DEBUGGING
4529     if (SvTEMP(sv)) {
4530         if (ckWARN_d(WARN_DEBUGGING))
4531             Perl_warner(aTHX_ WARN_DEBUGGING,
4532                         "Attempt to free temp prematurely: SV 0x%"UVxf,
4533                         PTR2UV(sv));
4534         return;
4535     }
4536 #endif
4537     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4538         /* make sure SvREFCNT(sv)==0 happens very seldom */
4539         SvREFCNT(sv) = (~(U32)0)/2;
4540         return;
4541     }
4542     sv_clear(sv);
4543     if (! SvREFCNT(sv))
4544         del_SV(sv);
4545 }
4546
4547 /*
4548 =for apidoc sv_len
4549
4550 Returns the length of the string in the SV.  See also C<SvCUR>.
4551
4552 =cut
4553 */
4554
4555 STRLEN
4556 Perl_sv_len(pTHX_ register SV *sv)
4557 {
4558     char *junk;
4559     STRLEN len;
4560
4561     if (!sv)
4562         return 0;
4563
4564     if (SvGMAGICAL(sv))
4565         len = mg_length(sv);
4566     else
4567         junk = SvPV(sv, len);
4568     return len;
4569 }
4570
4571 /*
4572 =for apidoc sv_len_utf8
4573
4574 Returns the number of characters in the string in an SV, counting wide
4575 UTF8 bytes as a single character.
4576
4577 =cut
4578 */
4579
4580 STRLEN
4581 Perl_sv_len_utf8(pTHX_ register SV *sv)
4582 {
4583     if (!sv)
4584         return 0;
4585
4586     if (SvGMAGICAL(sv))
4587         return mg_length(sv);
4588     else
4589     {
4590         STRLEN len;
4591         U8 *s = (U8*)SvPV(sv, len);
4592
4593         return Perl_utf8_length(aTHX_ s, s + len);
4594     }
4595 }
4596
4597 void
4598 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4599 {
4600     U8 *start;
4601     U8 *s;
4602     U8 *send;
4603     I32 uoffset = *offsetp;
4604     STRLEN len;
4605
4606     if (!sv)
4607         return;
4608
4609     start = s = (U8*)SvPV(sv, len);
4610     send = s + len;
4611     while (s < send && uoffset--)
4612         s += UTF8SKIP(s);
4613     if (s >= send)
4614         s = send;
4615     *offsetp = s - start;
4616     if (lenp) {
4617         I32 ulen = *lenp;
4618         start = s;
4619         while (s < send && ulen--)
4620             s += UTF8SKIP(s);
4621         if (s >= send)
4622             s = send;
4623         *lenp = s - start;
4624     }
4625     return;
4626 }
4627
4628 void
4629 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4630 {
4631     U8 *s;
4632     U8 *send;
4633     STRLEN len;
4634
4635     if (!sv)
4636         return;
4637
4638     s = (U8*)SvPV(sv, len);
4639     if (len < *offsetp)
4640         Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4641     send = s + *offsetp;
4642     len = 0;
4643     while (s < send) {
4644         STRLEN n;
4645
4646         if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) {
4647             s += n;
4648             len++;
4649         }
4650         else
4651             break;
4652     }
4653     *offsetp = len;
4654     return;
4655 }
4656
4657 /*
4658 =for apidoc sv_eq
4659
4660 Returns a boolean indicating whether the strings in the two SVs are
4661 identical.
4662
4663 =cut
4664 */
4665
4666 I32
4667 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4668 {
4669     char *pv1;
4670     STRLEN cur1;
4671     char *pv2;
4672     STRLEN cur2;
4673     I32  eq     = 0;
4674     bool pv1tmp = FALSE;
4675     bool pv2tmp = FALSE;
4676
4677     if (!sv1) {
4678         pv1 = "";
4679         cur1 = 0;
4680     }
4681     else
4682         pv1 = SvPV(sv1, cur1);
4683
4684     if (!sv2){
4685         pv2 = "";
4686         cur2 = 0;
4687     }
4688     else
4689         pv2 = SvPV(sv2, cur2);
4690
4691     /* do not utf8ize the comparands as a side-effect */
4692     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4693         if (PL_hints & HINT_UTF8_DISTINCT)
4694             return FALSE;
4695
4696         if (SvUTF8(sv1)) {
4697             (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
4698             {
4699                 IV scur1 = cur1;
4700                 if (scur1 < 0) {
4701                     Safefree(pv1);
4702                     return 0;
4703                 }
4704             }
4705             pv1tmp = TRUE;
4706         }
4707         else {
4708             (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
4709             {
4710                 IV scur2 = cur2;
4711                 if (scur2 < 0) {
4712                     Safefree(pv2);
4713                     return 0;
4714                 }
4715             }
4716             pv2tmp = TRUE;
4717         }
4718     }
4719
4720     if (cur1 == cur2)
4721         eq = memEQ(pv1, pv2, cur1);
4722
4723     if (pv1tmp)
4724         Safefree(pv1);
4725     if (pv2tmp)
4726         Safefree(pv2);
4727
4728     return eq;
4729 }
4730
4731 /*
4732 =for apidoc sv_cmp
4733
4734 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
4735 string in C<sv1> is less than, equal to, or greater than the string in
4736 C<sv2>.
4737
4738 =cut
4739 */
4740
4741 I32
4742 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4743 {
4744     STRLEN cur1, cur2;
4745     char *pv1, *pv2;
4746     I32  cmp;
4747     bool pv1tmp = FALSE;
4748     bool pv2tmp = FALSE;
4749
4750     if (!sv1) {
4751         pv1 = "";
4752         cur1 = 0;
4753     }
4754     else
4755         pv1 = SvPV(sv1, cur1);
4756
4757     if (!sv2){
4758         pv2 = "";
4759         cur2 = 0;
4760     }
4761     else
4762         pv2 = SvPV(sv2, cur2);
4763
4764     /* do not utf8ize the comparands as a side-effect */
4765     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4766         if (PL_hints & HINT_UTF8_DISTINCT)
4767             return SvUTF8(sv1) ? 1 : -1;
4768
4769         if (SvUTF8(sv1)) {
4770             pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4771             pv2tmp = TRUE;
4772         }
4773         else {
4774             pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4775             pv1tmp = TRUE;
4776         }
4777     }
4778
4779     if (!cur1) {
4780         cmp = cur2 ? -1 : 0;
4781     } else if (!cur2) {
4782         cmp = 1;
4783     } else {
4784         I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4785
4786         if (retval) {
4787             cmp = retval < 0 ? -1 : 1;
4788         } else if (cur1 == cur2) {
4789             cmp = 0;
4790         } else {
4791             cmp = cur1 < cur2 ? -1 : 1;
4792         }
4793     }
4794
4795     if (pv1tmp)
4796         Safefree(pv1);
4797     if (pv2tmp)
4798         Safefree(pv2);
4799
4800     return cmp;
4801 }
4802
4803 /*
4804 =for apidoc sv_cmp_locale
4805
4806 Compares the strings in two SVs in a locale-aware manner. See
4807 L</sv_cmp_locale>
4808
4809 =cut
4810 */
4811
4812 I32
4813 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4814 {
4815 #ifdef USE_LOCALE_COLLATE
4816
4817     char *pv1, *pv2;
4818     STRLEN len1, len2;
4819     I32 retval;
4820
4821     if (PL_collation_standard)
4822         goto raw_compare;
4823
4824     len1 = 0;
4825     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4826     len2 = 0;
4827     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4828
4829     if (!pv1 || !len1) {
4830         if (pv2 && len2)
4831             return -1;
4832         else
4833             goto raw_compare;
4834     }
4835     else {
4836         if (!pv2 || !len2)
4837             return 1;
4838     }
4839
4840     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4841
4842     if (retval)
4843         return retval < 0 ? -1 : 1;
4844
4845     /*
4846      * When the result of collation is equality, that doesn't mean
4847      * that there are no differences -- some locales exclude some
4848      * characters from consideration.  So to avoid false equalities,
4849      * we use the raw string as a tiebreaker.
4850      */
4851
4852   raw_compare:
4853     /* FALL THROUGH */
4854
4855 #endif /* USE_LOCALE_COLLATE */
4856
4857     return sv_cmp(sv1, sv2);
4858 }
4859
4860 #ifdef USE_LOCALE_COLLATE
4861 /*
4862  * Any scalar variable may carry an 'o' magic that contains the
4863  * scalar data of the variable transformed to such a format that
4864  * a normal memory comparison can be used to compare the data
4865  * according to the locale settings.
4866  */
4867 char *
4868 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4869 {
4870     MAGIC *mg;
4871
4872     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4873     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4874         char *s, *xf;
4875         STRLEN len, xlen;
4876
4877         if (mg)
4878             Safefree(mg->mg_ptr);
4879         s = SvPV(sv, len);
4880         if ((xf = mem_collxfrm(s, len, &xlen))) {
4881             if (SvREADONLY(sv)) {
4882                 SAVEFREEPV(xf);
4883                 *nxp = xlen;
4884                 return xf + sizeof(PL_collation_ix);
4885             }
4886             if (! mg) {
4887                 sv_magic(sv, 0, 'o', 0, 0);
4888                 mg = mg_find(sv, 'o');
4889                 assert(mg);
4890             }
4891             mg->mg_ptr = xf;
4892             mg->mg_len = xlen;
4893         }
4894         else {
4895             if (mg) {
4896                 mg->mg_ptr = NULL;
4897                 mg->mg_len = -1;
4898             }
4899         }
4900     }
4901     if (mg && mg->mg_ptr) {
4902         *nxp = mg->mg_len;
4903         return mg->mg_ptr + sizeof(PL_collation_ix);
4904     }
4905     else {
4906         *nxp = 0;
4907         return NULL;
4908     }
4909 }
4910
4911 #endif /* USE_LOCALE_COLLATE */
4912
4913 /*
4914 =for apidoc sv_gets
4915
4916 Get a line from the filehandle and store it into the SV, optionally
4917 appending to the currently-stored string.
4918
4919 =cut
4920 */
4921
4922 char *
4923 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4924 {
4925     char *rsptr;
4926     STRLEN rslen;
4927     register STDCHAR rslast;
4928     register STDCHAR *bp;
4929     register I32 cnt;
4930     I32 i;
4931
4932     SV_CHECK_THINKFIRST(sv);
4933     (void)SvUPGRADE(sv, SVt_PV);
4934
4935     SvSCREAM_off(sv);
4936
4937     if (RsSNARF(PL_rs)) {
4938         rsptr = NULL;
4939         rslen = 0;
4940     }
4941     else if (RsRECORD(PL_rs)) {
4942       I32 recsize, bytesread;
4943       char *buffer;
4944
4945       /* Grab the size of the record we're getting */
4946       recsize = SvIV(SvRV(PL_rs));
4947       (void)SvPOK_only(sv);    /* Validate pointer */
4948       buffer = SvGROW(sv, recsize + 1);
4949       /* Go yank in */
4950 #ifdef VMS
4951       /* VMS wants read instead of fread, because fread doesn't respect */
4952       /* RMS record boundaries. This is not necessarily a good thing to be */
4953       /* doing, but we've got no other real choice */
4954       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4955 #else
4956       bytesread = PerlIO_read(fp, buffer, recsize);
4957 #endif
4958       SvCUR_set(sv, bytesread);
4959       buffer[bytesread] = '\0';
4960       if (PerlIO_isutf8(fp))
4961         SvUTF8_on(sv);
4962       else
4963         SvUTF8_off(sv);
4964       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4965     }
4966     else if (RsPARA(PL_rs)) {
4967         rsptr = "\n\n";
4968         rslen = 2;
4969     }
4970     else {
4971         /* Get $/ i.e. PL_rs into same encoding as stream wants */
4972         if (PerlIO_isutf8(fp)) {
4973             rsptr = SvPVutf8(PL_rs, rslen);
4974         }
4975         else {
4976             if (SvUTF8(PL_rs)) {
4977                 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4978                     Perl_croak(aTHX_ "Wide character in $/");
4979                 }
4980             }
4981             rsptr = SvPV(PL_rs, rslen);
4982         }
4983     }
4984
4985     rslast = rslen ? rsptr[rslen - 1] : '\0';
4986
4987     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
4988         do {                    /* to make sure file boundaries work right */
4989             if (PerlIO_eof(fp))
4990                 return 0;
4991             i = PerlIO_getc(fp);
4992             if (i != '\n') {
4993                 if (i == -1)
4994                     return 0;
4995                 PerlIO_ungetc(fp,i);
4996                 break;
4997             }
4998         } while (i != EOF);
4999     }
5000
5001     /* See if we know enough about I/O mechanism to cheat it ! */
5002
5003     /* This used to be #ifdef test - it is made run-time test for ease
5004        of abstracting out stdio interface. One call should be cheap
5005        enough here - and may even be a macro allowing compile
5006        time optimization.
5007      */
5008
5009     if (PerlIO_fast_gets(fp)) {
5010
5011     /*
5012      * We're going to steal some values from the stdio struct
5013      * and put EVERYTHING in the innermost loop into registers.
5014      */
5015     register STDCHAR *ptr;
5016     STRLEN bpx;
5017     I32 shortbuffered;
5018
5019 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5020     /* An ungetc()d char is handled separately from the regular
5021      * buffer, so we getc() it back out and stuff it in the buffer.
5022      */
5023     i = PerlIO_getc(fp);
5024     if (i == EOF) return 0;
5025     *(--((*fp)->_ptr)) = (unsigned char) i;
5026     (*fp)->_cnt++;
5027 #endif
5028
5029     /* Here is some breathtakingly efficient cheating */
5030
5031     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
5032     (void)SvPOK_only(sv);               /* validate pointer */
5033     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5034         if (cnt > 80 && SvLEN(sv) > append) {
5035             shortbuffered = cnt - SvLEN(sv) + append + 1;
5036             cnt -= shortbuffered;
5037         }
5038         else {
5039             shortbuffered = 0;
5040             /* remember that cnt can be negative */
5041             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5042         }
5043     }
5044     else
5045         shortbuffered = 0;
5046     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
5047     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5048     DEBUG_P(PerlIO_printf(Perl_debug_log,
5049         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5050     DEBUG_P(PerlIO_printf(Perl_debug_log,
5051         "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5052                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5053                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5054     for (;;) {
5055       screamer:
5056         if (cnt > 0) {
5057             if (rslen) {
5058                 while (cnt > 0) {                    /* this     |  eat */
5059                     cnt--;
5060                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
5061                         goto thats_all_folks;        /* screams  |  sed :-) */
5062                 }
5063             }
5064             else {
5065                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
5066                 bp += cnt;                           /* screams  |  dust */
5067                 ptr += cnt;                          /* louder   |  sed :-) */
5068                 cnt = 0;
5069             }
5070         }
5071
5072         if (shortbuffered) {            /* oh well, must extend */
5073             cnt = shortbuffered;
5074             shortbuffered = 0;
5075             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5076             SvCUR_set(sv, bpx);
5077             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5078             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5079             continue;
5080         }
5081
5082         DEBUG_P(PerlIO_printf(Perl_debug_log,
5083                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5084                               PTR2UV(ptr),(long)cnt));
5085         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5086         DEBUG_P(PerlIO_printf(Perl_debug_log,
5087             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5088             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5089             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5090         /* This used to call 'filbuf' in stdio form, but as that behaves like
5091            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5092            another abstraction.  */
5093         i   = PerlIO_getc(fp);          /* get more characters */
5094         DEBUG_P(PerlIO_printf(Perl_debug_log,
5095             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5096             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5097             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5098         cnt = PerlIO_get_cnt(fp);
5099         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
5100         DEBUG_P(PerlIO_printf(Perl_debug_log,
5101             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5102
5103         if (i == EOF)                   /* all done for ever? */
5104             goto thats_really_all_folks;
5105
5106         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5107         SvCUR_set(sv, bpx);
5108         SvGROW(sv, bpx + cnt + 2);
5109         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5110
5111         *bp++ = i;                      /* store character from PerlIO_getc */
5112
5113         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
5114             goto thats_all_folks;
5115     }
5116
5117 thats_all_folks:
5118     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5119           memNE((char*)bp - rslen, rsptr, rslen))
5120         goto screamer;                          /* go back to the fray */
5121 thats_really_all_folks:
5122     if (shortbuffered)
5123         cnt += shortbuffered;
5124         DEBUG_P(PerlIO_printf(Perl_debug_log,
5125             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5126     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
5127     DEBUG_P(PerlIO_printf(Perl_debug_log,
5128         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5129         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5130         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5131     *bp = '\0';
5132     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
5133     DEBUG_P(PerlIO_printf(Perl_debug_log,
5134         "Screamer: done, len=%ld, string=|%.*s|\n",
5135         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5136     }
5137    else
5138     {
5139 #ifndef EPOC
5140        /*The big, slow, and stupid way */
5141         STDCHAR buf[8192];
5142 #else
5143         /* Need to work around EPOC SDK features          */
5144         /* On WINS: MS VC5 generates calls to _chkstk,    */
5145         /* if a `large' stack frame is allocated          */
5146         /* gcc on MARM does not generate calls like these */
5147         STDCHAR buf[1024];
5148 #endif
5149
5150 screamer2:
5151         if (rslen) {
5152             register STDCHAR *bpe = buf + sizeof(buf);
5153             bp = buf;
5154             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5155                 ; /* keep reading */
5156             cnt = bp - buf;
5157         }
5158         else {
5159             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5160             /* Accomodate broken VAXC compiler, which applies U8 cast to
5161              * both args of ?: operator, causing EOF to change into 255
5162              */
5163             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5164         }
5165
5166         if (append)
5167             sv_catpvn(sv, (char *) buf, cnt);
5168         else
5169             sv_setpvn(sv, (char *) buf, cnt);
5170
5171         if (i != EOF &&                 /* joy */
5172             (!rslen ||
5173              SvCUR(sv) < rslen ||
5174              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5175         {
5176             append = -1;
5177             /*
5178              * If we're reading from a TTY and we get a short read,
5179              * indicating that the user hit his EOF character, we need
5180              * to notice it now, because if we try to read from the TTY
5181              * again, the EOF condition will disappear.
5182              *
5183              * The comparison of cnt to sizeof(buf) is an optimization
5184              * that prevents unnecessary calls to feof().
5185              *
5186              * - jik 9/25/96
5187              */
5188             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5189                 goto screamer2;
5190         }
5191     }
5192
5193     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
5194         while (i != EOF) {      /* to make sure file boundaries work right */
5195             i = PerlIO_getc(fp);
5196             if (i != '\n') {
5197                 PerlIO_ungetc(fp,i);
5198                 break;
5199             }
5200         }
5201     }
5202
5203     if (PerlIO_isutf8(fp))
5204         SvUTF8_on(sv);
5205     else
5206         SvUTF8_off(sv);
5207
5208     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5209 }
5210
5211
5212 /*
5213 =for apidoc sv_inc
5214
5215 Auto-increment of the value in the SV.
5216
5217 =cut
5218 */
5219
5220 void
5221 Perl_sv_inc(pTHX_ register SV *sv)
5222 {
5223     register char *d;
5224     int flags;
5225
5226     if (!sv)
5227         return;
5228     if (SvGMAGICAL(sv))
5229         mg_get(sv);
5230     if (SvTHINKFIRST(sv)) {
5231         if (SvREADONLY(sv)) {
5232             if (PL_curcop != &PL_compiling)
5233                 Perl_croak(aTHX_ PL_no_modify);
5234         }
5235         if (SvROK(sv)) {
5236             IV i;
5237             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5238                 return;
5239             i = PTR2IV(SvRV(sv));
5240             sv_unref(sv);
5241             sv_setiv(sv, i);
5242         }
5243     }
5244     flags = SvFLAGS(sv);
5245     if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5246         /* It's (privately or publicly) a float, but not tested as an
5247            integer, so test it to see. */
5248         (void) SvIV(sv);
5249         flags = SvFLAGS(sv);
5250     }
5251     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5252         /* It's publicly an integer, or privately an integer-not-float */
5253       oops_its_int:
5254         if (SvIsUV(sv)) {
5255             if (SvUVX(sv) == UV_MAX)
5256                 sv_setnv(sv, (NV)UV_MAX + 1.0);
5257             else
5258                 (void)SvIOK_only_UV(sv);
5259                 ++SvUVX(sv);
5260         } else {
5261             if (SvIVX(sv) == IV_MAX)
5262                 sv_setuv(sv, (UV)IV_MAX + 1);
5263             else {
5264                 (void)SvIOK_only(sv);
5265                 ++SvIVX(sv);
5266             }
5267         }
5268         return;
5269     }
5270     if (flags & SVp_NOK) {
5271         (void)SvNOK_only(sv);
5272         SvNVX(sv) += 1.0;
5273         return;
5274     }
5275
5276     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5277         if ((flags & SVTYPEMASK) < SVt_PVIV)
5278             sv_upgrade(sv, SVt_IV);
5279         (void)SvIOK_only(sv);
5280         SvIVX(sv) = 1;
5281         return;
5282     }
5283     d = SvPVX(sv);
5284     while (isALPHA(*d)) d++;
5285     while (isDIGIT(*d)) d++;
5286     if (*d) {
5287 #ifdef PERL_PRESERVE_IVUV
5288         /* Got to punt this an an integer if needs be, but we don't issue
5289            warnings. Probably ought to make the sv_iv_please() that does
5290            the conversion if possible, and silently.  */
5291         I32 numtype = looks_like_number(sv);
5292         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5293             /* Need to try really hard to see if it's an integer.
5294                9.22337203685478e+18 is an integer.
5295                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5296                so $a="9.22337203685478e+18"; $a+0; $a++
5297                needs to be the same as $a="9.22337203685478e+18"; $a++
5298                or we go insane. */
5299
5300             (void) sv_2iv(sv);
5301             if (SvIOK(sv))
5302                 goto oops_its_int;
5303
5304             /* sv_2iv *should* have made this an NV */
5305             if (flags & SVp_NOK) {
5306                 (void)SvNOK_only(sv);
5307                 SvNVX(sv) += 1.0;
5308                 return;
5309             }
5310             /* I don't think we can get here. Maybe I should assert this
5311                And if we do get here I suspect that sv_setnv will croak. NWC
5312                Fall through. */
5313 #if defined(USE_LONG_DOUBLE)
5314             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",
5315                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5316 #else
5317             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5318                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5319 #endif
5320         }
5321 #endif /* PERL_PRESERVE_IVUV */
5322         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5323         return;
5324     }
5325     d--;
5326     while (d >= SvPVX(sv)) {
5327         if (isDIGIT(*d)) {
5328             if (++*d <= '9')
5329                 return;
5330             *(d--) = '0';
5331         }
5332         else {
5333 #ifdef EBCDIC
5334             /* MKS: The original code here died if letters weren't consecutive.
5335              * at least it didn't have to worry about non-C locales.  The
5336              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5337              * arranged in order (although not consecutively) and that only
5338              * [A-Za-z] are accepted by isALPHA in the C locale.
5339              */
5340             if (*d != 'z' && *d != 'Z') {
5341                 do { ++*d; } while (!isALPHA(*d));
5342                 return;
5343             }
5344             *(d--) -= 'z' - 'a';
5345 #else
5346             ++*d;
5347             if (isALPHA(*d))
5348                 return;
5349             *(d--) -= 'z' - 'a' + 1;
5350 #endif
5351         }
5352     }
5353     /* oh,oh, the number grew */
5354     SvGROW(sv, SvCUR(sv) + 2);
5355     SvCUR(sv)++;
5356     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5357         *d = d[-1];
5358     if (isDIGIT(d[1]))
5359         *d = '1';
5360     else
5361         *d = d[1];
5362 }
5363
5364 /*
5365 =for apidoc sv_dec
5366
5367 Auto-decrement of the value in the SV.
5368
5369 =cut
5370 */
5371
5372 void
5373 Perl_sv_dec(pTHX_ register SV *sv)
5374 {
5375     int flags;
5376
5377     if (!sv)
5378         return;
5379     if (SvGMAGICAL(sv))
5380         mg_get(sv);
5381     if (SvTHINKFIRST(sv)) {
5382         if (SvREADONLY(sv)) {
5383             if (PL_curcop != &PL_compiling)
5384                 Perl_croak(aTHX_ PL_no_modify);
5385         }
5386         if (SvROK(sv)) {
5387             IV i;
5388             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5389                 return;
5390             i = PTR2IV(SvRV(sv));
5391             sv_unref(sv);
5392             sv_setiv(sv, i);
5393         }
5394     }
5395     /* Unlike sv_inc we don't have to worry about string-never-numbers
5396        and keeping them magic. But we mustn't warn on punting */
5397     flags = SvFLAGS(sv);
5398     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5399         /* It's publicly an integer, or privately an integer-not-float */
5400       oops_its_int:
5401         if (SvIsUV(sv)) {
5402             if (SvUVX(sv) == 0) {
5403                 (void)SvIOK_only(sv);
5404                 SvIVX(sv) = -1;
5405             }
5406             else {
5407                 (void)SvIOK_only_UV(sv);
5408                 --SvUVX(sv);
5409             }
5410         } else {
5411             if (SvIVX(sv) == IV_MIN)
5412                 sv_setnv(sv, (NV)IV_MIN - 1.0);
5413             else {
5414                 (void)SvIOK_only(sv);
5415                 --SvIVX(sv);
5416             }
5417         }
5418         return;
5419     }
5420     if (flags & SVp_NOK) {
5421         SvNVX(sv) -= 1.0;
5422         (void)SvNOK_only(sv);
5423         return;
5424     }
5425     if (!(flags & SVp_POK)) {
5426         if ((flags & SVTYPEMASK) < SVt_PVNV)
5427             sv_upgrade(sv, SVt_NV);
5428         SvNVX(sv) = -1.0;
5429         (void)SvNOK_only(sv);
5430         return;
5431     }
5432 #ifdef PERL_PRESERVE_IVUV
5433     {
5434         I32 numtype = looks_like_number(sv);
5435         if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5436             /* Need to try really hard to see if it's an integer.
5437                9.22337203685478e+18 is an integer.
5438                but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5439                so $a="9.22337203685478e+18"; $a+0; $a--
5440                needs to be the same as $a="9.22337203685478e+18"; $a--
5441                or we go insane. */
5442
5443             (void) sv_2iv(sv);
5444             if (SvIOK(sv))
5445                 goto oops_its_int;
5446
5447             /* sv_2iv *should* have made this an NV */
5448             if (flags & SVp_NOK) {
5449                 (void)SvNOK_only(sv);
5450                 SvNVX(sv) -= 1.0;
5451                 return;
5452             }
5453             /* I don't think we can get here. Maybe I should assert this
5454                And if we do get here I suspect that sv_setnv will croak. NWC
5455                Fall through. */
5456 #if defined(USE_LONG_DOUBLE)
5457             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",
5458                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5459 #else
5460             DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5461                                   SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5462 #endif
5463         }
5464     }
5465 #endif /* PERL_PRESERVE_IVUV */
5466     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5467 }
5468
5469 /*
5470 =for apidoc sv_mortalcopy
5471
5472 Creates a new SV which is a copy of the original SV.  The new SV is marked
5473 as mortal.
5474
5475 =cut
5476 */
5477
5478 /* Make a string that will exist for the duration of the expression
5479  * evaluation.  Actually, it may have to last longer than that, but
5480  * hopefully we won't free it until it has been assigned to a
5481  * permanent location. */
5482
5483 SV *
5484 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5485 {
5486     register SV *sv;
5487
5488     new_SV(sv);
5489     sv_setsv(sv,oldstr);
5490     EXTEND_MORTAL(1);
5491     PL_tmps_stack[++PL_tmps_ix] = sv;
5492     SvTEMP_on(sv);
5493     return sv;
5494 }
5495
5496 /*
5497 =for apidoc sv_newmortal
5498
5499 Creates a new SV which is mortal.  The reference count of the SV is set to 1.
5500
5501 =cut
5502 */
5503
5504 SV *
5505 Perl_sv_newmortal(pTHX)
5506 {
5507     register SV *sv;
5508
5509     new_SV(sv);
5510     SvFLAGS(sv) = SVs_TEMP;
5511     EXTEND_MORTAL(1);
5512     PL_tmps_stack[++PL_tmps_ix] = sv;
5513     return sv;
5514 }
5515
5516 /*
5517 =for apidoc sv_2mortal
5518
5519 Marks an SV as mortal.  The SV will be destroyed when the current context
5520 ends.
5521
5522 =cut
5523 */
5524
5525 /* same thing without the copying */
5526
5527 SV *
5528 Perl_sv_2mortal(pTHX_ register SV *sv)
5529 {
5530     if (!sv)
5531         return sv;
5532     if (SvREADONLY(sv) && SvIMMORTAL(sv))
5533         return sv;
5534     EXTEND_MORTAL(1);
5535     PL_tmps_stack[++PL_tmps_ix] = sv;
5536     SvTEMP_on(sv);
5537     return sv;
5538 }
5539
5540 /*
5541 =for apidoc newSVpv
5542
5543 Creates a new SV and copies a string into it.  The reference count for the
5544 SV is set to 1.  If C<len> is zero, Perl will compute the length using
5545 strlen().  For efficiency, consider using C<newSVpvn> instead.
5546
5547 =cut
5548 */
5549
5550 SV *
5551 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5552 {
5553     register SV *sv;
5554
5555     new_SV(sv);
5556     if (!len)
5557         len = strlen(s);
5558     sv_setpvn(sv,s,len);
5559     return sv;
5560 }
5561
5562 /*
5563 =for apidoc newSVpvn
5564
5565 Creates a new SV and copies a string into it.  The reference count for the
5566 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
5567 string.  You are responsible for ensuring that the source string is at least
5568 C<len> bytes long.
5569
5570 =cut
5571 */
5572
5573 SV *
5574 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5575 {
5576     register SV *sv;
5577
5578     new_SV(sv);
5579     sv_setpvn(sv,s,len);
5580     return sv;
5581 }
5582
5583 /*
5584 =for apidoc newSVpvn_share
5585
5586 Creates a new SV and populates it with a string from
5587 the string table. Turns on READONLY and FAKE.
5588 The idea here is that as string table is used for shared hash
5589 keys these strings will have SvPVX == HeKEY and hash lookup
5590 will avoid string compare.
5591
5592 =cut
5593 */
5594
5595 SV *
5596 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5597 {
5598     register SV *sv;
5599     bool is_utf8 = FALSE;
5600     if (len < 0) {
5601         len = -len;
5602         is_utf8 = TRUE;
5603     }
5604     if (!hash)
5605         PERL_HASH(hash, src, len);
5606     new_SV(sv);
5607     sv_upgrade(sv, SVt_PVIV);
5608     SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5609     SvCUR(sv) = len;
5610     SvUVX(sv) = hash;
5611     SvLEN(sv) = 0;
5612     SvREADONLY_on(sv);
5613     SvFAKE_on(sv);
5614     SvPOK_on(sv);
5615     if (is_utf8)
5616         SvUTF8_on(sv);
5617     return sv;
5618 }
5619
5620 #if defined(PERL_IMPLICIT_CONTEXT)
5621 SV *
5622 Perl_newSVpvf_nocontext(const char* pat, ...)
5623 {
5624     dTHX;
5625     register SV *sv;
5626     va_list args;
5627     va_start(args, pat);
5628     sv = vnewSVpvf(pat, &args);
5629     va_end(args);
5630     return sv;
5631 }
5632 #endif
5633
5634 /*
5635 =for apidoc newSVpvf
5636
5637 Creates a new SV an initialize it with the string formatted like
5638 C<sprintf>.
5639
5640 =cut
5641 */
5642
5643 SV *
5644 Perl_newSVpvf(pTHX_ const char* pat, ...)
5645 {
5646     register SV *sv;
5647     va_list args;
5648     va_start(args, pat);
5649     sv = vnewSVpvf(pat, &args);
5650     va_end(args);
5651     return sv;
5652 }
5653
5654 SV *
5655 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5656 {
5657     register SV *sv;
5658     new_SV(sv);
5659     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5660     return sv;
5661 }
5662
5663 /*
5664 =for apidoc newSVnv
5665
5666 Creates a new SV and copies a floating point value into it.
5667 The reference count for the SV is set to 1.
5668
5669 =cut
5670 */
5671
5672 SV *
5673 Perl_newSVnv(pTHX_ NV n)
5674 {
5675     register SV *sv;
5676
5677     new_SV(sv);
5678     sv_setnv(sv,n);
5679     return sv;
5680 }
5681
5682 /*
5683 =for apidoc newSViv
5684
5685 Creates a new SV and copies an integer into it.  The reference count for the
5686 SV is set to 1.
5687
5688 =cut
5689 */
5690
5691 SV *
5692 Perl_newSViv(pTHX_ IV i)
5693 {
5694     register SV *sv;
5695
5696     new_SV(sv);
5697     sv_setiv(sv,i);
5698     return sv;
5699 }
5700
5701 /*
5702 =for apidoc newSVuv
5703
5704 Creates a new SV and copies an unsigned integer into it.
5705 The reference count for the SV is set to 1.
5706
5707 =cut
5708 */
5709
5710 SV *
5711 Perl_newSVuv(pTHX_ UV u)
5712 {
5713     register SV *sv;
5714
5715     new_SV(sv);
5716     sv_setuv(sv,u);
5717     return sv;
5718 }
5719
5720 /*
5721 =for apidoc newRV_noinc
5722
5723 Creates an RV wrapper for an SV.  The reference count for the original
5724 SV is B<not> incremented.
5725
5726 =cut
5727 */
5728
5729 SV *
5730 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5731 {
5732     register SV *sv;
5733
5734     new_SV(sv);
5735     sv_upgrade(sv, SVt_RV);
5736     SvTEMP_off(tmpRef);
5737     SvRV(sv) = tmpRef;
5738     SvROK_on(sv);
5739     return sv;
5740 }
5741
5742 /* newRV_inc is #defined to newRV in sv.h */
5743 SV *
5744 Perl_newRV(pTHX_ SV *tmpRef)
5745 {
5746     return newRV_noinc(SvREFCNT_inc(tmpRef));
5747 }
5748
5749 /*
5750 =for apidoc newSVsv
5751
5752 Creates a new SV which is an exact duplicate of the original SV.
5753
5754 =cut
5755 */
5756
5757 /* make an exact duplicate of old */
5758
5759 SV *
5760 Perl_newSVsv(pTHX_ register SV *old)
5761 {
5762     register SV *sv;
5763
5764     if (!old)
5765         return Nullsv;
5766     if (SvTYPE(old) == SVTYPEMASK) {
5767         if (ckWARN_d(WARN_INTERNAL))
5768             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5769         return Nullsv;
5770     }
5771     new_SV(sv);
5772     if (SvTEMP(old)) {
5773         SvTEMP_off(old);
5774         sv_setsv(sv,old);
5775         SvTEMP_on(old);
5776     }
5777     else
5778         sv_setsv(sv,old);
5779     return sv;
5780 }
5781
5782 void
5783 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5784 {
5785     register HE *entry;
5786     register GV *gv;
5787     register SV *sv;
5788     register I32 i;
5789     register PMOP *pm;
5790     register I32 max;
5791     char todo[PERL_UCHAR_MAX+1];
5792
5793     if (!stash)
5794         return;
5795
5796     if (!*s) {          /* reset ?? searches */
5797         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5798             pm->op_pmdynflags &= ~PMdf_USED;
5799         }
5800         return;
5801     }
5802
5803     /* reset variables */
5804
5805     if (!HvARRAY(stash))
5806         return;
5807
5808     Zero(todo, 256, char);
5809     while (*s) {
5810         i = (unsigned char)*s;
5811         if (s[1] == '-') {
5812             s += 2;
5813         }
5814         max = (unsigned char)*s++;
5815         for ( ; i <= max; i++) {
5816             todo[i] = 1;
5817         }
5818         for (i = 0; i <= (I32) HvMAX(stash); i++) {
5819             for (entry = HvARRAY(stash)[i];
5820                  entry;
5821                  entry = HeNEXT(entry))
5822             {
5823                 if (!todo[(U8)*HeKEY(entry)])
5824                     continue;
5825                 gv = (GV*)HeVAL(entry);
5826                 sv = GvSV(gv);
5827                 if (SvTHINKFIRST(sv)) {
5828                     if (!SvREADONLY(sv) && SvROK(sv))
5829                         sv_unref(sv);
5830                     continue;
5831                 }
5832                 (void)SvOK_off(sv);
5833                 if (SvTYPE(sv) >= SVt_PV) {
5834                     SvCUR_set(sv, 0);
5835                     if (SvPVX(sv) != Nullch)
5836                         *SvPVX(sv) = '\0';
5837                     SvTAINT(sv);
5838                 }
5839                 if (GvAV(gv)) {
5840                     av_clear(GvAV(gv));
5841                 }
5842                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5843                     hv_clear(GvHV(gv));
5844 #ifdef USE_ENVIRON_ARRAY
5845                     if (gv == PL_envgv)
5846                         environ[0] = Nullch;
5847 #endif
5848                 }
5849             }
5850         }
5851     }
5852 }
5853
5854 IO*
5855 Perl_sv_2io(pTHX_ SV *sv)
5856 {
5857     IO* io;
5858     GV* gv;
5859     STRLEN n_a;
5860
5861     switch (SvTYPE(sv)) {
5862     case SVt_PVIO:
5863         io = (IO*)sv;
5864         break;
5865     case SVt_PVGV:
5866         gv = (GV*)sv;
5867         io = GvIO(gv);
5868         if (!io)
5869             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5870         break;
5871     default:
5872         if (!SvOK(sv))
5873             Perl_croak(aTHX_ PL_no_usym, "filehandle");
5874         if (SvROK(sv))
5875             return sv_2io(SvRV(sv));
5876         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5877         if (gv)
5878             io = GvIO(gv);
5879         else
5880             io = 0;
5881         if (!io)
5882             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5883         break;
5884     }
5885     return io;
5886 }
5887
5888 CV *
5889 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5890 {
5891     GV *gv;
5892     CV *cv;
5893     STRLEN n_a;
5894
5895     if (!sv)
5896         return *gvp = Nullgv, Nullcv;
5897     switch (SvTYPE(sv)) {
5898     case SVt_PVCV:
5899         *st = CvSTASH(sv);
5900         *gvp = Nullgv;
5901         return (CV*)sv;
5902     case SVt_PVHV:
5903     case SVt_PVAV:
5904         *gvp = Nullgv;
5905         return Nullcv;
5906     case SVt_PVGV:
5907         gv = (GV*)sv;
5908         *gvp = gv;
5909         *st = GvESTASH(gv);
5910         goto fix_gv;
5911
5912     default:
5913         if (SvGMAGICAL(sv))
5914             mg_get(sv);
5915         if (SvROK(sv)) {
5916             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
5917             tryAMAGICunDEREF(to_cv);
5918
5919             sv = SvRV(sv);
5920             if (SvTYPE(sv) == SVt_PVCV) {
5921                 cv = (CV*)sv;
5922                 *gvp = Nullgv;
5923                 *st = CvSTASH(cv);
5924                 return cv;
5925             }
5926             else if(isGV(sv))
5927                 gv = (GV*)sv;
5928             else
5929                 Perl_croak(aTHX_ "Not a subroutine reference");
5930         }
5931         else if (isGV(sv))
5932             gv = (GV*)sv;
5933         else
5934             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5935         *gvp = gv;
5936         if (!gv)
5937             return Nullcv;
5938         *st = GvESTASH(gv);
5939     fix_gv:
5940         if (lref && !GvCVu(gv)) {
5941             SV *tmpsv;
5942             ENTER;
5943             tmpsv = NEWSV(704,0);
5944             gv_efullname3(tmpsv, gv, Nullch);
5945             /* XXX this is probably not what they think they're getting.
5946              * It has the same effect as "sub name;", i.e. just a forward
5947              * declaration! */
5948             newSUB(start_subparse(FALSE, 0),
5949                    newSVOP(OP_CONST, 0, tmpsv),
5950                    Nullop,
5951                    Nullop);
5952             LEAVE;
5953             if (!GvCVu(gv))
5954                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5955         }
5956         return GvCVu(gv);
5957     }
5958 }
5959
5960 /*
5961 =for apidoc sv_true
5962
5963 Returns true if the SV has a true value by Perl's rules.
5964
5965 =cut
5966 */
5967
5968 I32
5969 Perl_sv_true(pTHX_ register SV *sv)
5970 {
5971     if (!sv)
5972         return 0;
5973     if (SvPOK(sv)) {
5974         register XPV* tXpv;
5975         if ((tXpv = (XPV*)SvANY(sv)) &&
5976                 (tXpv->xpv_cur > 1 ||
5977                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5978             return 1;
5979         else
5980             return 0;
5981     }
5982     else {
5983         if (SvIOK(sv))
5984             return SvIVX(sv) != 0;
5985         else {
5986             if (SvNOK(sv))
5987                 return SvNVX(sv) != 0.0;
5988             else
5989                 return sv_2bool(sv);
5990         }
5991     }
5992 }
5993
5994 IV
5995 Perl_sv_iv(pTHX_ register SV *sv)
5996 {
5997     if (SvIOK(sv)) {
5998         if (SvIsUV(sv))
5999             return (IV)SvUVX(sv);
6000         return SvIVX(sv);
6001     }
6002     return sv_2iv(sv);
6003 }
6004
6005 UV
6006 Perl_sv_uv(pTHX_ register SV *sv)
6007 {
6008     if (SvIOK(sv)) {
6009         if (SvIsUV(sv))
6010             return SvUVX(sv);
6011         return (UV)SvIVX(sv);
6012     }
6013     return sv_2uv(sv);
6014 }
6015
6016 NV
6017 Perl_sv_nv(pTHX_ register SV *sv)
6018 {
6019     if (SvNOK(sv))
6020         return SvNVX(sv);
6021     return sv_2nv(sv);
6022 }
6023
6024 char *
6025 Perl_sv_pv(pTHX_ SV *sv)
6026 {
6027     STRLEN n_a;
6028
6029     if (SvPOK(sv))
6030         return SvPVX(sv);
6031
6032     return sv_2pv(sv, &n_a);
6033 }
6034
6035 char *
6036 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6037 {
6038     if (SvPOK(sv)) {
6039         *lp = SvCUR(sv);
6040         return SvPVX(sv);
6041     }
6042     return sv_2pv(sv, lp);
6043 }
6044
6045 /*
6046 =for apidoc sv_pvn_force
6047
6048 Get a sensible string out of the SV somehow.
6049
6050 =cut
6051 */
6052
6053 char *
6054 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6055 {
6056     char *s;
6057
6058     if (SvTHINKFIRST(sv) && !SvROK(sv))
6059         sv_force_normal(sv);
6060
6061     if (SvPOK(sv)) {
6062         *lp = SvCUR(sv);
6063     }
6064     else {
6065         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6066             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6067                 PL_op_name[PL_op->op_type]);
6068         }
6069         else
6070             s = sv_2pv(sv, lp);
6071         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
6072             STRLEN len = *lp;
6073
6074             if (SvROK(sv))
6075                 sv_unref(sv);
6076             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
6077             SvGROW(sv, len + 1);
6078             Move(s,SvPVX(sv),len,char);
6079             SvCUR_set(sv, len);
6080             *SvEND(sv) = '\0';
6081         }
6082         if (!SvPOK(sv)) {
6083             SvPOK_on(sv);               /* validate pointer */
6084             SvTAINT(sv);
6085             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6086                                   PTR2UV(sv),SvPVX(sv)));
6087         }
6088     }
6089     return SvPVX(sv);
6090 }
6091
6092 char *
6093 Perl_sv_pvbyte(pTHX_ SV *sv)
6094 {
6095     return sv_pv(sv);
6096 }
6097
6098 char *
6099 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6100 {
6101     return sv_pvn(sv,lp);
6102 }
6103
6104 char *
6105 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6106 {
6107     return sv_pvn_force(sv,lp);
6108 }
6109
6110 char *
6111 Perl_sv_pvutf8(pTHX_ SV *sv)
6112 {
6113     sv_utf8_upgrade(sv);
6114     return sv_pv(sv);
6115 }
6116
6117 char *
6118 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6119 {
6120     sv_utf8_upgrade(sv);
6121     return sv_pvn(sv,lp);
6122 }
6123
6124 /*
6125 =for apidoc sv_pvutf8n_force
6126
6127 Get a sensible UTF8-encoded string out of the SV somehow. See
6128 L</sv_pvn_force>.
6129
6130 =cut
6131 */
6132
6133 char *
6134 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6135 {
6136     sv_utf8_upgrade(sv);
6137     return sv_pvn_force(sv,lp);
6138 }
6139
6140 /*
6141 =for apidoc sv_reftype
6142
6143 Returns a string describing what the SV is a reference to.
6144
6145 =cut
6146 */
6147
6148 char *
6149 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6150 {
6151     if (ob && SvOBJECT(sv))
6152         return HvNAME(SvSTASH(sv));
6153     else {
6154         switch (SvTYPE(sv)) {
6155         case SVt_NULL:
6156         case SVt_IV:
6157         case SVt_NV:
6158         case SVt_RV:
6159         case SVt_PV:
6160         case SVt_PVIV:
6161         case SVt_PVNV:
6162         case SVt_PVMG:
6163         case SVt_PVBM:
6164                                 if (SvROK(sv))
6165                                     return "REF";
6166                                 else
6167                                     return "SCALAR";
6168         case SVt_PVLV:          return "LVALUE";
6169         case SVt_PVAV:          return "ARRAY";
6170         case SVt_PVHV:          return "HASH";
6171         case SVt_PVCV:          return "CODE";
6172         case SVt_PVGV:          return "GLOB";
6173         case SVt_PVFM:          return "FORMAT";
6174         case SVt_PVIO:          return "IO";
6175         default:                return "UNKNOWN";
6176         }
6177     }
6178 }
6179
6180 /*
6181 =for apidoc sv_isobject
6182
6183 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6184 object.  If the SV is not an RV, or if the object is not blessed, then this
6185 will return false.
6186
6187 =cut
6188 */
6189
6190 int
6191 Perl_sv_isobject(pTHX_ SV *sv)
6192 {
6193     if (!sv)
6194         return 0;
6195     if (SvGMAGICAL(sv))
6196         mg_get(sv);
6197     if (!SvROK(sv))
6198         return 0;
6199     sv = (SV*)SvRV(sv);
6200     if (!SvOBJECT(sv))
6201         return 0;
6202     return 1;
6203 }
6204
6205 /*
6206 =for apidoc sv_isa
6207
6208 Returns a boolean indicating whether the SV is blessed into the specified
6209 class.  This does not check for subtypes; use C<sv_derived_from> to verify
6210 an inheritance relationship.
6211
6212 =cut
6213 */
6214
6215 int
6216 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6217 {
6218     if (!sv)
6219         return 0;
6220     if (SvGMAGICAL(sv))
6221         mg_get(sv);
6222     if (!SvROK(sv))
6223         return 0;
6224     sv = (SV*)SvRV(sv);
6225     if (!SvOBJECT(sv))
6226         return 0;
6227
6228     return strEQ(HvNAME(SvSTASH(sv)), name);
6229 }
6230
6231 /*
6232 =for apidoc newSVrv
6233
6234 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
6235 it will be upgraded to one.  If C<classname> is non-null then the new SV will
6236 be blessed in the specified package.  The new SV is returned and its
6237 reference count is 1.
6238
6239 =cut
6240 */
6241
6242 SV*
6243 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6244 {
6245     SV *sv;
6246
6247     new_SV(sv);
6248
6249     SV_CHECK_THINKFIRST(rv);
6250     SvAMAGIC_off(rv);
6251
6252     if (SvTYPE(rv) >= SVt_PVMG) {
6253         U32 refcnt = SvREFCNT(rv);
6254         SvREFCNT(rv) = 0;
6255         sv_clear(rv);
6256         SvFLAGS(rv) = 0;
6257         SvREFCNT(rv) = refcnt;
6258     }
6259
6260     if (SvTYPE(rv) < SVt_RV)
6261         sv_upgrade(rv, SVt_RV);
6262     else if (SvTYPE(rv) > SVt_RV) {
6263         (void)SvOOK_off(rv);
6264         if (SvPVX(rv) && SvLEN(rv))
6265             Safefree(SvPVX(rv));
6266         SvCUR_set(rv, 0);
6267         SvLEN_set(rv, 0);
6268     }
6269
6270     (void)SvOK_off(rv);
6271     SvRV(rv) = sv;
6272     SvROK_on(rv);
6273
6274     if (classname) {
6275         HV* stash = gv_stashpv(classname, TRUE);
6276         (void)sv_bless(rv, stash);
6277     }
6278     return sv;
6279 }
6280
6281 /*
6282 =for apidoc sv_setref_pv
6283
6284 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
6285 argument will be upgraded to an RV.  That RV will be modified to point to
6286 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6287 into the SV.  The C<classname> argument indicates the package for the
6288 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
6289 will be returned and will have a reference count of 1.
6290
6291 Do not use with other Perl types such as HV, AV, SV, CV, because those
6292 objects will become corrupted by the pointer copy process.
6293
6294 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6295
6296 =cut
6297 */
6298
6299 SV*
6300 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6301 {
6302     if (!pv) {
6303         sv_setsv(rv, &PL_sv_undef);
6304         SvSETMAGIC(rv);
6305     }
6306     else
6307         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6308     return rv;
6309 }
6310
6311 /*
6312 =for apidoc sv_setref_iv
6313
6314 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
6315 argument will be upgraded to an RV.  That RV will be modified to point to
6316 the new SV.  The C<classname> argument indicates the package for the
6317 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
6318 will be returned and will have a reference count of 1.
6319
6320 =cut
6321 */
6322
6323 SV*
6324 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6325 {
6326     sv_setiv(newSVrv(rv,classname), iv);
6327     return rv;
6328 }
6329
6330 /*
6331 =for apidoc sv_setref_nv
6332
6333 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
6334 argument will be upgraded to an RV.  That RV will be modified to point to
6335 the new SV.  The C<classname> argument indicates the package for the
6336 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
6337 will be returned and will have a reference count of 1.
6338
6339 =cut
6340 */
6341
6342 SV*
6343 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6344 {
6345     sv_setnv(newSVrv(rv,classname), nv);
6346     return rv;
6347 }
6348
6349 /*
6350 =for apidoc sv_setref_pvn
6351
6352 Copies a string into a new SV, optionally blessing the SV.  The length of the
6353 string must be specified with C<n>.  The C<rv> argument will be upgraded to
6354 an RV.  That RV will be modified to point to the new SV.  The C<classname>
6355 argument indicates the package for the blessing.  Set C<classname> to
6356 C<Nullch> to avoid the blessing.  The new SV will be returned and will have
6357 a reference count of 1.
6358
6359 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6360
6361 =cut
6362 */
6363
6364 SV*
6365 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6366 {
6367     sv_setpvn(newSVrv(rv,classname), pv, n);
6368     return rv;
6369 }
6370
6371 /*
6372 =for apidoc sv_bless
6373
6374 Blesses an SV into a specified package.  The SV must be an RV.  The package
6375 must be designated by its stash (see C<gv_stashpv()>).  The reference count
6376 of the SV is unaffected.
6377
6378 =cut
6379 */
6380
6381 SV*
6382 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6383 {
6384     SV *tmpRef;
6385     if (!SvROK(sv))
6386         Perl_croak(aTHX_ "Can't bless non-reference value");
6387     tmpRef = SvRV(sv);
6388     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6389         if (SvREADONLY(tmpRef))
6390             Perl_croak(aTHX_ PL_no_modify);
6391         if (SvOBJECT(tmpRef)) {
6392             if (SvTYPE(tmpRef) != SVt_PVIO)
6393                 --PL_sv_objcount;
6394             SvREFCNT_dec(SvSTASH(tmpRef));
6395         }
6396     }
6397     SvOBJECT_on(tmpRef);
6398     if (SvTYPE(tmpRef) != SVt_PVIO)
6399         ++PL_sv_objcount;
6400     (void)SvUPGRADE(tmpRef, SVt_PVMG);
6401     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6402
6403     if (Gv_AMG(stash))
6404         SvAMAGIC_on(sv);
6405     else
6406         SvAMAGIC_off(sv);
6407
6408     return sv;
6409 }
6410
6411 STATIC void
6412 S_sv_unglob(pTHX_ SV *sv)
6413 {
6414     void *xpvmg;
6415
6416     assert(SvTYPE(sv) == SVt_PVGV);
6417     SvFAKE_off(sv);
6418     if (GvGP(sv))
6419         gp_free((GV*)sv);
6420     if (GvSTASH(sv)) {
6421         SvREFCNT_dec(GvSTASH(sv));
6422         GvSTASH(sv) = Nullhv;
6423     }
6424     sv_unmagic(sv, '*');
6425     Safefree(GvNAME(sv));
6426     GvMULTI_off(sv);
6427
6428     /* need to keep SvANY(sv) in the right arena */
6429     xpvmg = new_XPVMG();
6430     StructCopy(SvANY(sv), xpvmg, XPVMG);
6431     del_XPVGV(SvANY(sv));
6432     SvANY(sv) = xpvmg;
6433
6434     SvFLAGS(sv) &= ~SVTYPEMASK;
6435     SvFLAGS(sv) |= SVt_PVMG;
6436 }
6437
6438 /*
6439 =for apidoc sv_unref_flags
6440
6441 Unsets the RV status of the SV, and decrements the reference count of
6442 whatever was being referenced by the RV.  This can almost be thought of
6443 as a reversal of C<newSVrv>.  The C<cflags> argument can contain
6444 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6445 (otherwise the decrementing is conditional on the reference count being
6446 different from one or the reference being a readonly SV).
6447 See C<SvROK_off>.
6448
6449 =cut
6450 */
6451
6452 void
6453 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6454 {
6455     SV* rv = SvRV(sv);
6456
6457     if (SvWEAKREF(sv)) {
6458         sv_del_backref(sv);
6459         SvWEAKREF_off(sv);
6460         SvRV(sv) = 0;
6461         return;
6462     }
6463     SvRV(sv) = 0;
6464     SvROK_off(sv);
6465     if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6466         SvREFCNT_dec(rv);
6467     else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6468         sv_2mortal(rv);         /* Schedule for freeing later */
6469 }
6470
6471 /*
6472 =for apidoc sv_unref
6473
6474 Unsets the RV status of the SV, and decrements the reference count of
6475 whatever was being referenced by the RV.  This can almost be thought of
6476 as a reversal of C<newSVrv>.  This is C<sv_unref_flags> with the C<flag>
6477 being zero.  See C<SvROK_off>.
6478
6479 =cut
6480 */
6481
6482 void
6483 Perl_sv_unref(pTHX_ SV *sv)
6484 {
6485     sv_unref_flags(sv, 0);
6486 }
6487
6488 void
6489 Perl_sv_taint(pTHX_ SV *sv)
6490 {
6491     sv_magic((sv), Nullsv, 't', Nullch, 0);
6492 }
6493
6494 void
6495 Perl_sv_untaint(pTHX_ SV *sv)
6496 {
6497     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6498         MAGIC *mg = mg_find(sv, 't');
6499         if (mg)
6500             mg->mg_len &= ~1;
6501     }
6502 }
6503
6504 bool
6505 Perl_sv_tainted(pTHX_ SV *sv)
6506 {
6507     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6508         MAGIC *mg = mg_find(sv, 't');
6509         if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6510             return TRUE;
6511     }
6512     return FALSE;
6513 }
6514
6515 /*
6516 =for apidoc sv_setpviv
6517
6518 Copies an integer into the given SV, also updating its string value.
6519 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
6520
6521 =cut
6522 */
6523
6524 void
6525 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6526 {
6527     char buf[TYPE_CHARS(UV)];
6528     char *ebuf;
6529     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6530
6531     sv_setpvn(sv, ptr, ebuf - ptr);
6532 }
6533
6534
6535 /*
6536 =for apidoc sv_setpviv_mg
6537
6538 Like C<sv_setpviv>, but also handles 'set' magic.
6539
6540 =cut
6541 */
6542
6543 void
6544 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6545 {
6546     char buf[TYPE_CHARS(UV)];
6547     char *ebuf;
6548     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6549
6550     sv_setpvn(sv, ptr, ebuf - ptr);
6551     SvSETMAGIC(sv);
6552 }
6553
6554 #if defined(PERL_IMPLICIT_CONTEXT)
6555 void
6556 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6557 {
6558     dTHX;
6559     va_list args;
6560     va_start(args, pat);
6561     sv_vsetpvf(sv, pat, &args);
6562     va_end(args);
6563 }
6564
6565
6566 void
6567 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6568 {
6569     dTHX;
6570     va_list args;
6571     va_start(args, pat);
6572     sv_vsetpvf_mg(sv, pat, &args);
6573     va_end(args);
6574 }
6575 #endif
6576
6577 /*
6578 =for apidoc sv_setpvf
6579
6580 Processes its arguments like C<sprintf> and sets an SV to the formatted
6581 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
6582
6583 =cut
6584 */
6585
6586 void
6587 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6588 {
6589     va_list args;
6590     va_start(args, pat);
6591     sv_vsetpvf(sv, pat, &args);
6592     va_end(args);
6593 }
6594
6595 void
6596 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6597 {
6598     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6599 }
6600
6601 /*
6602 =for apidoc sv_setpvf_mg
6603
6604 Like C<sv_setpvf>, but also handles 'set' magic.
6605
6606 =cut
6607 */
6608
6609 void
6610 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6611 {
6612     va_list args;
6613     va_start(args, pat);
6614     sv_vsetpvf_mg(sv, pat, &args);
6615     va_end(args);
6616 }
6617
6618 void
6619 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6620 {
6621     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6622     SvSETMAGIC(sv);
6623 }
6624
6625 #if defined(PERL_IMPLICIT_CONTEXT)
6626 void
6627 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6628 {
6629     dTHX;
6630     va_list args;
6631     va_start(args, pat);
6632     sv_vcatpvf(sv, pat, &args);
6633     va_end(args);
6634 }
6635
6636 void
6637 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6638 {
6639     dTHX;
6640     va_list args;
6641     va_start(args, pat);
6642     sv_vcatpvf_mg(sv, pat, &args);
6643     va_end(args);
6644 }
6645 #endif
6646
6647 /*
6648 =for apidoc sv_catpvf
6649
6650 Processes its arguments like C<sprintf> and appends the formatted output
6651 to an SV.  Handles 'get' magic, but not 'set' magic.  C<SvSETMAGIC()> must
6652 typically be called after calling this function to handle 'set' magic.
6653
6654 =cut
6655 */
6656
6657 void
6658 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6659 {
6660     va_list args;
6661     va_start(args, pat);
6662     sv_vcatpvf(sv, pat, &args);
6663     va_end(args);
6664 }
6665
6666 void
6667 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6668 {
6669     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6670 }
6671
6672 /*
6673 =for apidoc sv_catpvf_mg
6674
6675 Like C<sv_catpvf>, but also handles 'set' magic.
6676
6677 =cut
6678 */
6679
6680 void
6681 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6682 {
6683     va_list args;
6684     va_start(args, pat);
6685     sv_vcatpvf_mg(sv, pat, &args);
6686     va_end(args);
6687 }
6688
6689 void
6690 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6691 {
6692     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6693     SvSETMAGIC(sv);
6694 }
6695
6696 /*
6697 =for apidoc sv_vsetpvfn
6698
6699 Works like C<vcatpvfn> but copies the text into the SV instead of
6700 appending it.
6701
6702 =cut
6703 */
6704
6705 void
6706 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6707 {
6708     sv_setpvn(sv, "", 0);
6709     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6710 }
6711
6712 I32
6713 S_expect_number(pTHX_ char** pattern)
6714 {
6715     I32 var = 0;
6716     switch (**pattern) {
6717     case '1': case '2': case '3':
6718     case '4': case '5': case '6':
6719     case '7': case '8': case '9':
6720         while (isDIGIT(**pattern))
6721             var = var * 10 + (*(*pattern)++ - '0');
6722     }
6723     return var;
6724 }
6725 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6726
6727 /*
6728 =for apidoc sv_vcatpvfn
6729
6730 Processes its arguments like C<vsprintf> and appends the formatted output
6731 to an SV.  Uses an array of SVs if the C style variable argument list is
6732 missing (NULL).  When running with taint checks enabled, indicates via
6733 C<maybe_tainted> if results are untrustworthy (often due to the use of
6734 locales).
6735
6736 =cut
6737 */
6738
6739 void
6740 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6741 {
6742     char *p;
6743     char *q;
6744     char *patend;
6745     STRLEN origlen;
6746     I32 svix = 0;
6747     static char nullstr[] = "(null)";
6748     SV *argsv;
6749
6750     /* no matter what, this is a string now */
6751     (void)SvPV_force(sv, origlen);
6752
6753     /* special-case "", "%s", and "%_" */
6754     if (patlen == 0)
6755         return;
6756     if (patlen == 2 && pat[0] == '%') {
6757         switch (pat[1]) {
6758         case 's':
6759             if (args) {
6760                 char *s = va_arg(*args, char*);
6761                 sv_catpv(sv, s ? s : nullstr);
6762             }
6763             else if (svix < svmax) {
6764                 sv_catsv(sv, *svargs);
6765                 if (DO_UTF8(*svargs))
6766                     SvUTF8_on(sv);
6767             }
6768             return;
6769         case '_':
6770             if (args) {
6771                 argsv = va_arg(*args, SV*);
6772                 sv_catsv(sv, argsv);
6773                 if (DO_UTF8(argsv))
6774                     SvUTF8_on(sv);
6775                 return;
6776             }
6777             /* See comment on '_' below */
6778             break;
6779         }
6780     }
6781
6782     patend = (char*)pat + patlen;
6783     for (p = (char*)pat; p < patend; p = q) {
6784         bool alt = FALSE;
6785         bool left = FALSE;
6786         bool vectorize = FALSE;
6787         bool vectorarg = FALSE;
6788         bool vec_utf = FALSE;
6789         char fill = ' ';
6790         char plus = 0;
6791         char intsize = 0;
6792         STRLEN width = 0;
6793         STRLEN zeros = 0;
6794         bool has_precis = FALSE;
6795         STRLEN precis = 0;
6796         bool is_utf = FALSE;
6797
6798         char esignbuf[4];
6799         U8 utf8buf[UTF8_MAXLEN+1];
6800         STRLEN esignlen = 0;
6801
6802         char *eptr = Nullch;
6803         STRLEN elen = 0;
6804         /* Times 4: a decimal digit takes more than 3 binary digits.
6805          * NV_DIG: mantissa takes than many decimal digits.
6806          * Plus 32: Playing safe. */
6807         char ebuf[IV_DIG * 4 + NV_DIG + 32];
6808         /* large enough for "%#.#f" --chip */
6809         /* what about long double NVs? --jhi */
6810
6811         SV *vecsv;
6812         U8 *vecstr = Null(U8*);
6813         STRLEN veclen = 0;
6814         char c;
6815         int i;
6816         unsigned base;
6817         IV iv;
6818         UV uv;
6819         NV nv;
6820         STRLEN have;
6821         STRLEN need;
6822         STRLEN gap;
6823         char *dotstr = ".";
6824         STRLEN dotstrlen = 1;
6825         I32 efix = 0; /* explicit format parameter index */
6826         I32 ewix = 0; /* explicit width index */
6827         I32 epix = 0; /* explicit precision index */
6828         I32 evix = 0; /* explicit vector index */
6829         bool asterisk = FALSE;
6830
6831         /* echo everything up to the next format specification */
6832         for (q = p; q < patend && *q != '%'; ++q) ;
6833         if (q > p) {
6834             sv_catpvn(sv, p, q - p);
6835             p = q;
6836         }
6837         if (q++ >= patend)
6838             break;
6839
6840 /*
6841     We allow format specification elements in this order:
6842         \d+\$              explicit format parameter index
6843         [-+ 0#]+           flags
6844         \*?(\d+\$)?v       vector with optional (optionally specified) arg
6845         \d+|\*(\d+\$)?     width using optional (optionally specified) arg
6846         \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
6847         [hlqLV]            size
6848     [%bcdefginopsux_DFOUX] format (mandatory)
6849 */
6850         if (EXPECT_NUMBER(q, width)) {
6851             if (*q == '$') {
6852                 ++q;
6853                 efix = width;
6854             } else {
6855                 goto gotwidth;
6856             }
6857         }
6858
6859         /* FLAGS */
6860
6861         while (*q) {
6862             switch (*q) {
6863             case ' ':
6864             case '+':
6865                 plus = *q++;
6866                 continue;
6867
6868             case '-':
6869                 left = TRUE;
6870                 q++;
6871                 continue;
6872
6873             case '0':
6874                 fill = *q++;
6875                 continue;
6876
6877             case '#':
6878                 alt = TRUE;
6879                 q++;
6880                 continue;
6881
6882             default:
6883                 break;
6884             }
6885             break;
6886         }
6887
6888       tryasterisk:
6889         if (*q == '*') {
6890             q++;
6891             if (EXPECT_NUMBER(q, ewix))
6892                 if (*q++ != '$')
6893                     goto unknown;
6894             asterisk = TRUE;
6895         }
6896         if (*q == 'v') {
6897             q++;
6898             if (vectorize)
6899                 goto unknown;
6900             if (vectorarg = asterisk) {
6901                 evix = ewix;
6902                 ewix = 0;
6903                 asterisk = FALSE;
6904             }
6905             vectorize = TRUE;
6906             goto tryasterisk;
6907         }
6908
6909         if (!asterisk)
6910             EXPECT_NUMBER(q, width);
6911
6912         if (vectorize) {
6913             if (vectorarg) {
6914                 if (args)
6915                     vecsv = va_arg(*args, SV*);
6916                 else
6917                     vecsv = (evix ? evix <= svmax : svix < svmax) ?
6918                         svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
6919                 dotstr = SvPVx(vecsv, dotstrlen);
6920                 if (DO_UTF8(vecsv))
6921                     is_utf = TRUE;
6922             }
6923             if (args) {
6924                 vecsv = va_arg(*args, SV*);
6925                 vecstr = (U8*)SvPVx(vecsv,veclen);
6926                 vec_utf = DO_UTF8(vecsv);
6927             }
6928             else if (efix ? efix <= svmax : svix < svmax) {
6929                 vecsv = svargs[efix ? efix-1 : svix++];
6930                 vecstr = (U8*)SvPVx(vecsv,veclen);
6931                 vec_utf = DO_UTF8(vecsv);
6932             }
6933             else {
6934                 vecstr = (U8*)"";
6935                 veclen = 0;
6936             }
6937         }
6938
6939         if (asterisk) {
6940             if (args)
6941                 i = va_arg(*args, int);
6942             else
6943                 i = (ewix ? ewix <= svmax : svix < svmax) ?
6944                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6945             left |= (i < 0);
6946             width = (i < 0) ? -i : i;
6947         }
6948       gotwidth:
6949
6950         /* PRECISION */
6951
6952         if (*q == '.') {
6953             q++;
6954             if (*q == '*') {
6955                 q++;
6956                 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
6957                     goto unknown;
6958                 if (args)
6959                     i = va_arg(*args, int);
6960                 else
6961                     i = (ewix ? ewix <= svmax : svix < svmax)
6962                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6963                 precis = (i < 0) ? 0 : i;
6964             }
6965             else {
6966                 precis = 0;
6967                 while (isDIGIT(*q))
6968                     precis = precis * 10 + (*q++ - '0');
6969             }
6970             has_precis = TRUE;
6971         }
6972
6973         /* SIZE */
6974
6975         switch (*q) {
6976 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6977         case 'L':                       /* Ld */
6978             /* FALL THROUGH */
6979 #endif
6980 #ifdef HAS_QUAD
6981         case 'q':                       /* qd */
6982             intsize = 'q';
6983             q++;
6984             break;
6985 #endif
6986         case 'l':
6987 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6988              if (*(q + 1) == 'l') {     /* lld, llf */
6989                 intsize = 'q';
6990                 q += 2;
6991                 break;
6992              }
6993 #endif
6994             /* FALL THROUGH */
6995         case 'h':
6996             /* FALL THROUGH */
6997         case 'V':
6998             intsize = *q++;
6999             break;
7000         }
7001
7002         /* CONVERSION */
7003
7004         if (*q == '%') {
7005             eptr = q++;
7006             elen = 1;
7007             goto string;
7008         }
7009
7010         if (!args)
7011             argsv = (efix ? efix <= svmax : svix < svmax) ?
7012                     svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7013
7014         switch (c = *q++) {
7015
7016             /* STRINGS */
7017
7018         case 'c':
7019             uv = args ? va_arg(*args, int) : SvIVx(argsv);
7020             if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
7021                 eptr = (char*)utf8buf;
7022                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
7023                 is_utf = TRUE;
7024             }
7025             else {
7026                 c = (char)uv;
7027                 eptr = &c;
7028                 elen = 1;
7029             }
7030             goto string;
7031
7032         case 's':
7033             if (args) {
7034                 eptr = va_arg(*args, char*);
7035                 if (eptr)
7036 #ifdef MACOS_TRADITIONAL
7037                   /* On MacOS, %#s format is used for Pascal strings */
7038                   if (alt)
7039                     elen = *eptr++;
7040                   else
7041 #endif
7042                     elen = strlen(eptr);
7043                 else {
7044                     eptr = nullstr;
7045                     elen = sizeof nullstr - 1;
7046                 }
7047             }
7048             else {
7049                 eptr = SvPVx(argsv, elen);
7050                 if (DO_UTF8(argsv)) {
7051                     if (has_precis && precis < elen) {
7052                         I32 p = precis;
7053                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7054                         precis = p;
7055                     }
7056                     if (width) { /* fudge width (can't fudge elen) */
7057                         width += elen - sv_len_utf8(argsv);
7058                     }
7059                     is_utf = TRUE;
7060                 }
7061             }
7062             goto string;
7063
7064         case '_':
7065             /*
7066              * The "%_" hack might have to be changed someday,
7067              * if ISO or ANSI decide to use '_' for something.
7068              * So we keep it hidden from users' code.
7069              */
7070             if (!args)
7071                 goto unknown;
7072             argsv = va_arg(*args, SV*);
7073             eptr = SvPVx(argsv, elen);
7074             if (DO_UTF8(argsv))
7075                 is_utf = TRUE;
7076
7077         string:
7078             vectorize = FALSE;
7079             if (has_precis && elen > precis)
7080                 elen = precis;
7081             break;
7082
7083             /* INTEGERS */
7084
7085         case 'p':
7086             if (alt)
7087                 goto unknown;
7088             uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7089             base = 16;
7090             goto integer;
7091
7092         case 'D':
7093 #ifdef IV_IS_QUAD
7094             intsize = 'q';
7095 #else
7096             intsize = 'l';
7097 #endif
7098             /* FALL THROUGH */
7099         case 'd':
7100         case 'i':
7101             if (vectorize) {
7102                 STRLEN ulen;
7103                 if (!veclen)
7104                     continue;
7105                 if (vec_utf)
7106                     iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7107                 else {
7108                     iv = *vecstr;
7109                     ulen = 1;
7110                 }
7111                 vecstr += ulen;
7112                 veclen -= ulen;
7113             }
7114             else if (args) {
7115                 switch (intsize) {
7116                 case 'h':       iv = (short)va_arg(*args, int); break;
7117                 default:        iv = va_arg(*args, int); break;
7118                 case 'l':       iv = va_arg(*args, long); break;
7119                 case 'V':       iv = va_arg(*args, IV); break;
7120 #ifdef HAS_QUAD
7121                 case 'q':       iv = va_arg(*args, Quad_t); break;
7122 #endif
7123                 }
7124             }
7125             else {
7126                 iv = SvIVx(argsv);
7127                 switch (intsize) {
7128                 case 'h':       iv = (short)iv; break;
7129                 default:        break;
7130                 case 'l':       iv = (long)iv; break;
7131                 case 'V':       break;
7132 #ifdef HAS_QUAD
7133                 case 'q':       iv = (Quad_t)iv; break;
7134 #endif
7135                 }
7136             }
7137             if (iv >= 0) {
7138                 uv = iv;
7139                 if (plus)
7140                     esignbuf[esignlen++] = plus;
7141             }
7142             else {
7143                 uv = -iv;
7144                 esignbuf[esignlen++] = '-';
7145             }
7146             base = 10;
7147             goto integer;
7148
7149         case 'U':
7150 #ifdef IV_IS_QUAD
7151             intsize = 'q';
7152 #else
7153             intsize = 'l';
7154 #endif
7155             /* FALL THROUGH */
7156         case 'u':
7157             base = 10;
7158             goto uns_integer;
7159
7160         case 'b':
7161             base = 2;
7162             goto uns_integer;
7163
7164         case 'O':
7165 #ifdef IV_IS_QUAD
7166             intsize = 'q';
7167 #else
7168             intsize = 'l';
7169 #endif
7170             /* FALL THROUGH */
7171         case 'o':
7172             base = 8;
7173             goto uns_integer;
7174
7175         case 'X':
7176         case 'x':
7177             base = 16;
7178
7179         uns_integer:
7180             if (vectorize) {
7181                 STRLEN ulen;
7182         vector:
7183                 if (!veclen)
7184                     continue;
7185                 if (vec_utf)
7186                     uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7187                 else {
7188                     uv = *vecstr;
7189                     ulen = 1;
7190                 }
7191                 vecstr += ulen;
7192                 veclen -= ulen;
7193             }
7194             else if (args) {
7195                 switch (intsize) {
7196                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
7197                 default:   uv = va_arg(*args, unsigned); break;
7198                 case 'l':  uv = va_arg(*args, unsigned long); break;
7199                 case 'V':  uv = va_arg(*args, UV); break;
7200 #ifdef HAS_QUAD
7201                 case 'q':  uv = va_arg(*args, Quad_t); break;
7202 #endif
7203                 }
7204             }
7205             else {
7206                 uv = SvUVx(argsv);
7207                 switch (intsize) {
7208                 case 'h':       uv = (unsigned short)uv; break;
7209                 default:        break;
7210                 case 'l':       uv = (unsigned long)uv; break;
7211                 case 'V':       break;
7212 #ifdef HAS_QUAD
7213                 case 'q':       uv = (Quad_t)uv; break;
7214 #endif
7215                 }
7216             }
7217
7218         integer:
7219             eptr = ebuf + sizeof ebuf;
7220             switch (base) {
7221                 unsigned dig;
7222             case 16:
7223                 if (!uv)
7224                     alt = FALSE;
7225                 p = (char*)((c == 'X')
7226                             ? "0123456789ABCDEF" : "0123456789abcdef");
7227                 do {
7228                     dig = uv & 15;
7229                     *--eptr = p[dig];
7230                 } while (uv >>= 4);
7231                 if (alt) {
7232                     esignbuf[esignlen++] = '0';
7233                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
7234                 }
7235                 break;
7236             case 8:
7237                 do {
7238                     dig = uv & 7;
7239                     *--eptr = '0' + dig;
7240                 } while (uv >>= 3);
7241                 if (alt && *eptr != '0')
7242                     *--eptr = '0';
7243                 break;
7244             case 2:
7245                 do {
7246                     dig = uv & 1;
7247                     *--eptr = '0' + dig;
7248                 } while (uv >>= 1);
7249                 if (alt) {
7250                     esignbuf[esignlen++] = '0';
7251                     esignbuf[esignlen++] = 'b';
7252                 }
7253                 break;
7254             default:            /* it had better be ten or less */
7255 #if defined(PERL_Y2KWARN)
7256                 if (ckWARN(WARN_Y2K)) {
7257                     STRLEN n;
7258                     char *s = SvPV(sv,n);
7259                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7260                         && (n == 2 || !isDIGIT(s[n-3])))
7261                     {
7262                         Perl_warner(aTHX_ WARN_Y2K,
7263                                     "Possible Y2K bug: %%%c %s",
7264                                     c, "format string following '19'");
7265                     }
7266                 }
7267 #endif
7268                 do {
7269                     dig = uv % base;
7270                     *--eptr = '0' + dig;
7271                 } while (uv /= base);
7272                 break;
7273             }
7274             elen = (ebuf + sizeof ebuf) - eptr;
7275             if (has_precis) {
7276                 if (precis > elen)
7277                     zeros = precis - elen;
7278                 else if (precis == 0 && elen == 1 && *eptr == '0')
7279                     elen = 0;
7280             }
7281             break;
7282
7283             /* FLOATING POINT */
7284
7285         case 'F':
7286             c = 'f';            /* maybe %F isn't supported here */
7287             /* FALL THROUGH */
7288         case 'e': case 'E':
7289         case 'f':
7290         case 'g': case 'G':
7291
7292             /* This is evil, but floating point is even more evil */
7293
7294             vectorize = FALSE;
7295             nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7296
7297             need = 0;
7298             if (c != 'e' && c != 'E') {
7299                 i = PERL_INT_MIN;
7300                 (void)Perl_frexp(nv, &i);
7301                 if (i == PERL_INT_MIN)
7302                     Perl_die(aTHX_ "panic: frexp");
7303                 if (i > 0)
7304                     need = BIT_DIGITS(i);
7305             }
7306             need += has_precis ? precis : 6; /* known default */
7307             if (need < width)
7308                 need = width;
7309
7310             need += 20; /* fudge factor */
7311             if (PL_efloatsize < need) {
7312                 Safefree(PL_efloatbuf);
7313                 PL_efloatsize = need + 20; /* more fudge */
7314                 New(906, PL_efloatbuf, PL_efloatsize, char);
7315                 PL_efloatbuf[0] = '\0';
7316             }
7317
7318             eptr = ebuf + sizeof ebuf;
7319             *--eptr = '\0';
7320             *--eptr = c;
7321 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7322             {
7323                 /* Copy the one or more characters in a long double
7324                  * format before the 'base' ([efgEFG]) character to
7325                  * the format string. */
7326                 static char const prifldbl[] = PERL_PRIfldbl;
7327                 char const *p = prifldbl + sizeof(prifldbl) - 3;
7328                 while (p >= prifldbl) { *--eptr = *p--; }
7329             }
7330 #endif
7331             if (has_precis) {
7332                 base = precis;
7333                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7334                 *--eptr = '.';
7335             }
7336             if (width) {
7337                 base = width;
7338                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7339             }
7340             if (fill == '0')
7341                 *--eptr = fill;
7342             if (left)
7343                 *--eptr = '-';
7344             if (plus)
7345                 *--eptr = plus;
7346             if (alt)
7347                 *--eptr = '#';
7348             *--eptr = '%';
7349
7350             /* No taint.  Otherwise we are in the strange situation
7351              * where printf() taints but print($float) doesn't.
7352              * --jhi */
7353             (void)sprintf(PL_efloatbuf, eptr, nv);
7354
7355             eptr = PL_efloatbuf;
7356             elen = strlen(PL_efloatbuf);
7357             break;
7358
7359             /* SPECIAL */
7360
7361         case 'n':
7362             vectorize = FALSE;
7363             i = SvCUR(sv) - origlen;
7364             if (args) {
7365                 switch (intsize) {
7366                 case 'h':       *(va_arg(*args, short*)) = i; break;
7367                 default:        *(va_arg(*args, int*)) = i; break;
7368                 case 'l':       *(va_arg(*args, long*)) = i; break;
7369                 case 'V':       *(va_arg(*args, IV*)) = i; break;
7370 #ifdef HAS_QUAD
7371                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
7372 #endif
7373                 }
7374             }
7375             else
7376                 sv_setuv_mg(argsv, (UV)i);
7377             continue;   /* not "break" */
7378
7379             /* UNKNOWN */
7380
7381         default:
7382       unknown:
7383             vectorize = FALSE;
7384             if (!args && ckWARN(WARN_PRINTF) &&
7385                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7386                 SV *msg = sv_newmortal();
7387                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7388                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7389                 if (c) {
7390                     if (isPRINT(c))
7391                         Perl_sv_catpvf(aTHX_ msg,
7392                                        "\"%%%c\"", c & 0xFF);
7393                     else
7394                         Perl_sv_catpvf(aTHX_ msg,
7395                                        "\"%%\\%03"UVof"\"",
7396                                        (UV)c & 0xFF);
7397                 } else
7398                     sv_catpv(msg, "end of string");
7399                 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7400             }
7401
7402             /* output mangled stuff ... */
7403             if (c == '\0')
7404                 --q;
7405             eptr = p;
7406             elen = q - p;
7407
7408             /* ... right here, because formatting flags should not apply */
7409             SvGROW(sv, SvCUR(sv) + elen + 1);
7410             p = SvEND(sv);
7411             Copy(eptr, p, elen, char);
7412             p += elen;
7413             *p = '\0';
7414             SvCUR(sv) = p - SvPVX(sv);
7415             continue;   /* not "break" */
7416         }
7417
7418         have = esignlen + zeros + elen;
7419         need = (have > width ? have : width);
7420         gap = need - have;
7421
7422         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7423         p = SvEND(sv);
7424         if (esignlen && fill == '0') {
7425             for (i = 0; i < esignlen; i++)
7426                 *p++ = esignbuf[i];
7427         }
7428         if (gap && !left) {
7429             memset(p, fill, gap);
7430             p += gap;
7431         }
7432         if (esignlen && fill != '0') {
7433             for (i = 0; i < esignlen; i++)
7434                 *p++ = esignbuf[i];
7435         }
7436         if (zeros) {
7437             for (i = zeros; i; i--)
7438                 *p++ = '0';
7439         }
7440         if (elen) {
7441             Copy(eptr, p, elen, char);
7442             p += elen;
7443         }
7444         if (gap && left) {
7445             memset(p, ' ', gap);
7446             p += gap;
7447         }
7448         if (vectorize) {
7449             if (veclen) {
7450                 Copy(dotstr, p, dotstrlen, char);
7451                 p += dotstrlen;
7452             }
7453             else
7454                 vectorize = FALSE;              /* done iterating over vecstr */
7455         }
7456         if (is_utf)
7457             SvUTF8_on(sv);
7458         *p = '\0';
7459         SvCUR(sv) = p - SvPVX(sv);
7460         if (vectorize) {
7461             esignlen = 0;
7462             goto vector;
7463         }
7464     }
7465 }
7466
7467 #if defined(USE_ITHREADS)
7468
7469 #if defined(USE_THREADS)
7470 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
7471 #endif
7472
7473 #ifndef GpREFCNT_inc
7474 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7475 #endif
7476
7477
7478 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
7479 #define av_dup(s)       (AV*)sv_dup((SV*)s)
7480 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7481 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
7482 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7483 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
7484 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7485 #define io_dup(s)       (IO*)sv_dup((SV*)s)
7486 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7487 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
7488 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7489 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
7490 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
7491
7492 REGEXP *
7493 Perl_re_dup(pTHX_ REGEXP *r)
7494 {
7495     /* XXX fix when pmop->op_pmregexp becomes shared */
7496     return ReREFCNT_inc(r);
7497 }
7498
7499 PerlIO *
7500 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7501 {
7502     PerlIO *ret;
7503     if (!fp)
7504         return (PerlIO*)NULL;
7505
7506     /* look for it in the table first */
7507     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7508     if (ret)
7509         return ret;
7510
7511     /* create anew and remember what it is */
7512     ret = PerlIO_fdupopen(aTHX_ fp);
7513     ptr_table_store(PL_ptr_table, fp, ret);
7514     return ret;
7515 }
7516
7517 DIR *
7518 Perl_dirp_dup(pTHX_ DIR *dp)
7519 {
7520     if (!dp)
7521         return (DIR*)NULL;
7522     /* XXX TODO */
7523     return dp;
7524 }
7525
7526 GP *
7527 Perl_gp_dup(pTHX_ GP *gp)
7528 {
7529     GP *ret;
7530     if (!gp)
7531         return (GP*)NULL;
7532     /* look for it in the table first */
7533     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7534     if (ret)
7535         return ret;
7536
7537     /* create anew and remember what it is */
7538     Newz(0, ret, 1, GP);
7539     ptr_table_store(PL_ptr_table, gp, ret);
7540
7541     /* clone */
7542     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
7543     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
7544     ret->gp_io          = io_dup_inc(gp->gp_io);
7545     ret->gp_form        = cv_dup_inc(gp->gp_form);
7546     ret->gp_av          = av_dup_inc(gp->gp_av);
7547     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
7548     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
7549     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
7550     ret->gp_cvgen       = gp->gp_cvgen;
7551     ret->gp_flags       = gp->gp_flags;
7552     ret->gp_line        = gp->gp_line;
7553     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
7554     return ret;
7555 }
7556
7557 MAGIC *
7558 Perl_mg_dup(pTHX_ MAGIC *mg)
7559 {
7560     MAGIC *mgret = (MAGIC*)NULL;
7561     MAGIC *mgprev;
7562     if (!mg)
7563         return (MAGIC*)NULL;
7564     /* look for it in the table first */
7565     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7566     if (mgret)
7567         return mgret;
7568
7569     for (; mg; mg = mg->mg_moremagic) {
7570         MAGIC *nmg;
7571         Newz(0, nmg, 1, MAGIC);
7572         if (!mgret)
7573             mgret = nmg;
7574         else
7575             mgprev->mg_moremagic = nmg;
7576         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
7577         nmg->mg_private = mg->mg_private;
7578         nmg->mg_type    = mg->mg_type;
7579         nmg->mg_flags   = mg->mg_flags;
7580         if (mg->mg_type == 'r') {
7581             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7582         }
7583         else {
7584             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7585                               ? sv_dup_inc(mg->mg_obj)
7586                               : sv_dup(mg->mg_obj);
7587         }
7588         nmg->mg_len     = mg->mg_len;
7589         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
7590         if (mg->mg_ptr && mg->mg_type != 'g') {
7591             if (mg->mg_len >= 0) {
7592                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
7593                 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7594                     AMT *amtp = (AMT*)mg->mg_ptr;
7595                     AMT *namtp = (AMT*)nmg->mg_ptr;
7596                     I32 i;
7597                     for (i = 1; i < NofAMmeth; i++) {
7598                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
7599                     }
7600                 }
7601             }
7602             else if (mg->mg_len == HEf_SVKEY)
7603                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7604         }
7605         mgprev = nmg;
7606     }
7607     return mgret;
7608 }
7609
7610 PTR_TBL_t *
7611 Perl_ptr_table_new(pTHX)
7612 {
7613     PTR_TBL_t *tbl;
7614     Newz(0, tbl, 1, PTR_TBL_t);
7615     tbl->tbl_max        = 511;
7616     tbl->tbl_items      = 0;
7617     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7618     return tbl;
7619 }
7620
7621 void *
7622 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7623 {
7624     PTR_TBL_ENT_t *tblent;
7625     UV hash = PTR2UV(sv);
7626     assert(tbl);
7627     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7628     for (; tblent; tblent = tblent->next) {
7629         if (tblent->oldval == sv)
7630             return tblent->newval;
7631     }
7632     return (void*)NULL;
7633 }
7634
7635 void
7636 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7637 {
7638     PTR_TBL_ENT_t *tblent, **otblent;
7639     /* XXX this may be pessimal on platforms where pointers aren't good
7640      * hash values e.g. if they grow faster in the most significant
7641      * bits */
7642     UV hash = PTR2UV(oldv);
7643     bool i = 1;
7644
7645     assert(tbl);
7646     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7647     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7648         if (tblent->oldval == oldv) {
7649             tblent->newval = newv;
7650             tbl->tbl_items++;
7651             return;
7652         }
7653     }
7654     Newz(0, tblent, 1, PTR_TBL_ENT_t);
7655     tblent->oldval = oldv;
7656     tblent->newval = newv;
7657     tblent->next = *otblent;
7658     *otblent = tblent;
7659     tbl->tbl_items++;
7660     if (i && tbl->tbl_items > tbl->tbl_max)
7661         ptr_table_split(tbl);
7662 }
7663
7664 void
7665 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7666 {
7667     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7668     UV oldsize = tbl->tbl_max + 1;
7669     UV newsize = oldsize * 2;
7670     UV i;
7671
7672     Renew(ary, newsize, PTR_TBL_ENT_t*);
7673     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7674     tbl->tbl_max = --newsize;
7675     tbl->tbl_ary = ary;
7676     for (i=0; i < oldsize; i++, ary++) {
7677         PTR_TBL_ENT_t **curentp, **entp, *ent;
7678         if (!*ary)
7679             continue;
7680         curentp = ary + oldsize;
7681         for (entp = ary, ent = *ary; ent; ent = *entp) {
7682             if ((newsize & PTR2UV(ent->oldval)) != i) {
7683                 *entp = ent->next;
7684                 ent->next = *curentp;
7685                 *curentp = ent;
7686                 continue;
7687             }
7688             else
7689                 entp = &ent->next;
7690         }
7691     }
7692 }
7693
7694 #ifdef DEBUGGING
7695 char *PL_watch_pvx;
7696 #endif
7697
7698 SV *
7699 Perl_sv_dup(pTHX_ SV *sstr)
7700 {
7701     SV *dstr;
7702
7703     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7704         return Nullsv;
7705     /* look for it in the table first */
7706     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7707     if (dstr)
7708         return dstr;
7709
7710     /* create anew and remember what it is */
7711     new_SV(dstr);
7712     ptr_table_store(PL_ptr_table, sstr, dstr);
7713
7714     /* clone */
7715     SvFLAGS(dstr)       = SvFLAGS(sstr);
7716     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
7717     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
7718
7719 #ifdef DEBUGGING
7720     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7721         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7722                       PL_watch_pvx, SvPVX(sstr));
7723 #endif
7724
7725     switch (SvTYPE(sstr)) {
7726     case SVt_NULL:
7727         SvANY(dstr)     = NULL;
7728         break;
7729     case SVt_IV:
7730         SvANY(dstr)     = new_XIV();
7731         SvIVX(dstr)     = SvIVX(sstr);
7732         break;
7733     case SVt_NV:
7734         SvANY(dstr)     = new_XNV();
7735         SvNVX(dstr)     = SvNVX(sstr);
7736         break;
7737     case SVt_RV:
7738         SvANY(dstr)     = new_XRV();
7739         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
7740         break;
7741     case SVt_PV:
7742         SvANY(dstr)     = new_XPV();
7743         SvCUR(dstr)     = SvCUR(sstr);
7744         SvLEN(dstr)     = SvLEN(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_PVIV:
7753         SvANY(dstr)     = new_XPVIV();
7754         SvCUR(dstr)     = SvCUR(sstr);
7755         SvLEN(dstr)     = SvLEN(sstr);
7756         SvIVX(dstr)     = SvIVX(sstr);
7757         if (SvROK(sstr))
7758             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7759         else if (SvPVX(sstr) && SvLEN(sstr))
7760             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7761         else
7762             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7763         break;
7764     case SVt_PVNV:
7765         SvANY(dstr)     = new_XPVNV();
7766         SvCUR(dstr)     = SvCUR(sstr);
7767         SvLEN(dstr)     = SvLEN(sstr);
7768         SvIVX(dstr)     = SvIVX(sstr);
7769         SvNVX(dstr)     = SvNVX(sstr);
7770         if (SvROK(sstr))
7771             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7772         else if (SvPVX(sstr) && SvLEN(sstr))
7773             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7774         else
7775             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7776         break;
7777     case SVt_PVMG:
7778         SvANY(dstr)     = new_XPVMG();
7779         SvCUR(dstr)     = SvCUR(sstr);
7780         SvLEN(dstr)     = SvLEN(sstr);
7781         SvIVX(dstr)     = SvIVX(sstr);
7782         SvNVX(dstr)     = SvNVX(sstr);
7783         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7784         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7785         if (SvROK(sstr))
7786             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7787         else if (SvPVX(sstr) && SvLEN(sstr))
7788             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7789         else
7790             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7791         break;
7792     case SVt_PVBM:
7793         SvANY(dstr)     = new_XPVBM();
7794         SvCUR(dstr)     = SvCUR(sstr);
7795         SvLEN(dstr)     = SvLEN(sstr);
7796         SvIVX(dstr)     = SvIVX(sstr);
7797         SvNVX(dstr)     = SvNVX(sstr);
7798         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7799         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7800         if (SvROK(sstr))
7801             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7802         else if (SvPVX(sstr) && SvLEN(sstr))
7803             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7804         else
7805             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7806         BmRARE(dstr)    = BmRARE(sstr);
7807         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
7808         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7809         break;
7810     case SVt_PVLV:
7811         SvANY(dstr)     = new_XPVLV();
7812         SvCUR(dstr)     = SvCUR(sstr);
7813         SvLEN(dstr)     = SvLEN(sstr);
7814         SvIVX(dstr)     = SvIVX(sstr);
7815         SvNVX(dstr)     = SvNVX(sstr);
7816         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7817         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7818         if (SvROK(sstr))
7819             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7820         else if (SvPVX(sstr) && SvLEN(sstr))
7821             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7822         else
7823             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7824         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
7825         LvTARGLEN(dstr) = LvTARGLEN(sstr);
7826         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
7827         LvTYPE(dstr)    = LvTYPE(sstr);
7828         break;
7829     case SVt_PVGV:
7830         SvANY(dstr)     = new_XPVGV();
7831         SvCUR(dstr)     = SvCUR(sstr);
7832         SvLEN(dstr)     = SvLEN(sstr);
7833         SvIVX(dstr)     = SvIVX(sstr);
7834         SvNVX(dstr)     = SvNVX(sstr);
7835         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7836         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7837         if (SvROK(sstr))
7838             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7839         else if (SvPVX(sstr) && SvLEN(sstr))
7840             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7841         else
7842             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7843         GvNAMELEN(dstr) = GvNAMELEN(sstr);
7844         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7845         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
7846         GvFLAGS(dstr)   = GvFLAGS(sstr);
7847         GvGP(dstr)      = gp_dup(GvGP(sstr));
7848         (void)GpREFCNT_inc(GvGP(dstr));
7849         break;
7850     case SVt_PVIO:
7851         SvANY(dstr)     = new_XPVIO();
7852         SvCUR(dstr)     = SvCUR(sstr);
7853         SvLEN(dstr)     = SvLEN(sstr);
7854         SvIVX(dstr)     = SvIVX(sstr);
7855         SvNVX(dstr)     = SvNVX(sstr);
7856         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7857         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7858         if (SvROK(sstr))
7859             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
7860         else if (SvPVX(sstr) && SvLEN(sstr))
7861             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7862         else
7863             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7864         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7865         if (IoOFP(sstr) == IoIFP(sstr))
7866             IoOFP(dstr) = IoIFP(dstr);
7867         else
7868             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7869         /* PL_rsfp_filters entries have fake IoDIRP() */
7870         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7871             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
7872         else
7873             IoDIRP(dstr)        = IoDIRP(sstr);
7874         IoLINES(dstr)           = IoLINES(sstr);
7875         IoPAGE(dstr)            = IoPAGE(sstr);
7876         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
7877         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
7878         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
7879         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
7880         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
7881         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
7882         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
7883         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
7884         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
7885         IoTYPE(dstr)            = IoTYPE(sstr);
7886         IoFLAGS(dstr)           = IoFLAGS(sstr);
7887         break;
7888     case SVt_PVAV:
7889         SvANY(dstr)     = new_XPVAV();
7890         SvCUR(dstr)     = SvCUR(sstr);
7891         SvLEN(dstr)     = SvLEN(sstr);
7892         SvIVX(dstr)     = SvIVX(sstr);
7893         SvNVX(dstr)     = SvNVX(sstr);
7894         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7895         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7896         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7897         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7898         if (AvARRAY((AV*)sstr)) {
7899             SV **dst_ary, **src_ary;
7900             SSize_t items = AvFILLp((AV*)sstr) + 1;
7901
7902             src_ary = AvARRAY((AV*)sstr);
7903             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7904             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7905             SvPVX(dstr) = (char*)dst_ary;
7906             AvALLOC((AV*)dstr) = dst_ary;
7907             if (AvREAL((AV*)sstr)) {
7908                 while (items-- > 0)
7909                     *dst_ary++ = sv_dup_inc(*src_ary++);
7910             }
7911             else {
7912                 while (items-- > 0)
7913                     *dst_ary++ = sv_dup(*src_ary++);
7914             }
7915             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7916             while (items-- > 0) {
7917                 *dst_ary++ = &PL_sv_undef;
7918             }
7919         }
7920         else {
7921             SvPVX(dstr)         = Nullch;
7922             AvALLOC((AV*)dstr)  = (SV**)NULL;
7923         }
7924         break;
7925     case SVt_PVHV:
7926         SvANY(dstr)     = new_XPVHV();
7927         SvCUR(dstr)     = SvCUR(sstr);
7928         SvLEN(dstr)     = SvLEN(sstr);
7929         SvIVX(dstr)     = SvIVX(sstr);
7930         SvNVX(dstr)     = SvNVX(sstr);
7931         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7932         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7933         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
7934         if (HvARRAY((HV*)sstr)) {
7935             STRLEN i = 0;
7936             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7937             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7938             Newz(0, dxhv->xhv_array,
7939                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7940             while (i <= sxhv->xhv_max) {
7941                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7942                                                     !!HvSHAREKEYS(sstr));
7943                 ++i;
7944             }
7945             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7946         }
7947         else {
7948             SvPVX(dstr)         = Nullch;
7949             HvEITER((HV*)dstr)  = (HE*)NULL;
7950         }
7951         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
7952         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
7953         break;
7954     case SVt_PVFM:
7955         SvANY(dstr)     = new_XPVFM();
7956         FmLINES(dstr)   = FmLINES(sstr);
7957         goto dup_pvcv;
7958         /* NOTREACHED */
7959     case SVt_PVCV:
7960         SvANY(dstr)     = new_XPVCV();
7961 dup_pvcv:
7962         SvCUR(dstr)     = SvCUR(sstr);
7963         SvLEN(dstr)     = SvLEN(sstr);
7964         SvIVX(dstr)     = SvIVX(sstr);
7965         SvNVX(dstr)     = SvNVX(sstr);
7966         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7967         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7968         if (SvPVX(sstr) && SvLEN(sstr))
7969             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7970         else
7971             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7972         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7973         CvSTART(dstr)   = CvSTART(sstr);
7974         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
7975         CvXSUB(dstr)    = CvXSUB(sstr);
7976         CvXSUBANY(dstr) = CvXSUBANY(sstr);
7977         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
7978         CvDEPTH(dstr)   = CvDEPTH(sstr);
7979         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7980             /* XXX padlists are real, but pretend to be not */
7981             AvREAL_on(CvPADLIST(sstr));
7982             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
7983             AvREAL_off(CvPADLIST(sstr));
7984             AvREAL_off(CvPADLIST(dstr));
7985         }
7986         else
7987             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
7988         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7989         CvFLAGS(dstr)   = CvFLAGS(sstr);
7990         break;
7991     default:
7992         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7993         break;
7994     }
7995
7996     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7997         ++PL_sv_objcount;
7998
7999     return dstr;
8000 }
8001
8002 PERL_CONTEXT *
8003 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8004 {
8005     PERL_CONTEXT *ncxs;
8006
8007     if (!cxs)
8008         return (PERL_CONTEXT*)NULL;
8009
8010     /* look for it in the table first */
8011     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8012     if (ncxs)
8013         return ncxs;
8014
8015     /* create anew and remember what it is */
8016     Newz(56, ncxs, max + 1, PERL_CONTEXT);
8017     ptr_table_store(PL_ptr_table, cxs, ncxs);
8018
8019     while (ix >= 0) {
8020         PERL_CONTEXT *cx = &cxs[ix];
8021         PERL_CONTEXT *ncx = &ncxs[ix];
8022         ncx->cx_type    = cx->cx_type;
8023         if (CxTYPE(cx) == CXt_SUBST) {
8024             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8025         }
8026         else {
8027             ncx->blk_oldsp      = cx->blk_oldsp;
8028             ncx->blk_oldcop     = cx->blk_oldcop;
8029             ncx->blk_oldretsp   = cx->blk_oldretsp;
8030             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
8031             ncx->blk_oldscopesp = cx->blk_oldscopesp;
8032             ncx->blk_oldpm      = cx->blk_oldpm;
8033             ncx->blk_gimme      = cx->blk_gimme;
8034             switch (CxTYPE(cx)) {
8035             case CXt_SUB:
8036                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
8037                                            ? cv_dup_inc(cx->blk_sub.cv)
8038                                            : cv_dup(cx->blk_sub.cv));
8039                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
8040                                            ? av_dup_inc(cx->blk_sub.argarray)
8041                                            : Nullav);
8042                 ncx->blk_sub.savearray  = av_dup(cx->blk_sub.savearray);
8043                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
8044                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
8045                 ncx->blk_sub.lval       = cx->blk_sub.lval;
8046                 break;
8047             case CXt_EVAL:
8048                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8049                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8050                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8051                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8052                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text);
8053                 break;
8054             case CXt_LOOP:
8055                 ncx->blk_loop.label     = cx->blk_loop.label;
8056                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
8057                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
8058                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
8059                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
8060                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
8061                                            ? cx->blk_loop.iterdata
8062                                            : gv_dup((GV*)cx->blk_loop.iterdata));
8063                 ncx->blk_loop.oldcurpad
8064                     = (SV**)ptr_table_fetch(PL_ptr_table,
8065                                             cx->blk_loop.oldcurpad);
8066                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave);
8067                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval);
8068                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary);
8069                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
8070                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
8071                 break;
8072             case CXt_FORMAT:
8073                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv);
8074                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv);
8075                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv);
8076                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
8077                 break;
8078             case CXt_BLOCK:
8079             case CXt_NULL:
8080                 break;
8081             }
8082         }
8083         --ix;
8084     }
8085     return ncxs;
8086 }
8087
8088 PERL_SI *
8089 Perl_si_dup(pTHX_ PERL_SI *si)
8090 {
8091     PERL_SI *nsi;
8092
8093     if (!si)
8094         return (PERL_SI*)NULL;
8095
8096     /* look for it in the table first */
8097     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8098     if (nsi)
8099         return nsi;
8100
8101     /* create anew and remember what it is */
8102     Newz(56, nsi, 1, PERL_SI);
8103     ptr_table_store(PL_ptr_table, si, nsi);
8104
8105     nsi->si_stack       = av_dup_inc(si->si_stack);
8106     nsi->si_cxix        = si->si_cxix;
8107     nsi->si_cxmax       = si->si_cxmax;
8108     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8109     nsi->si_type        = si->si_type;
8110     nsi->si_prev        = si_dup(si->si_prev);
8111     nsi->si_next        = si_dup(si->si_next);
8112     nsi->si_markoff     = si->si_markoff;
8113
8114     return nsi;
8115 }
8116
8117 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
8118 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
8119 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
8120 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
8121 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
8122 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
8123 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
8124 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
8125 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
8126 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
8127 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8128 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8129
8130 /* XXXXX todo */
8131 #define pv_dup_inc(p)   SAVEPV(p)
8132 #define pv_dup(p)       SAVEPV(p)
8133 #define svp_dup_inc(p,pp)       any_dup(p,pp)
8134
8135 void *
8136 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8137 {
8138     void *ret;
8139
8140     if (!v)
8141         return (void*)NULL;
8142
8143     /* look for it in the table first */
8144     ret = ptr_table_fetch(PL_ptr_table, v);
8145     if (ret)
8146         return ret;
8147
8148     /* see if it is part of the interpreter structure */
8149     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8150         ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8151     else
8152         ret = v;
8153
8154     return ret;
8155 }
8156
8157 ANY *
8158 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8159 {
8160     ANY *ss     = proto_perl->Tsavestack;
8161     I32 ix      = proto_perl->Tsavestack_ix;
8162     I32 max     = proto_perl->Tsavestack_max;
8163     ANY *nss;
8164     SV *sv;
8165     GV *gv;
8166     AV *av;
8167     HV *hv;
8168     void* ptr;
8169     int intval;
8170     long longval;
8171     GP *gp;
8172     IV iv;
8173     I32 i;
8174     char *c;
8175     void (*dptr) (void*);
8176     void (*dxptr) (pTHXo_ void*);
8177     OP *o;
8178
8179     Newz(54, nss, max, ANY);
8180
8181     while (ix > 0) {
8182         i = POPINT(ss,ix);
8183         TOPINT(nss,ix) = i;
8184         switch (i) {
8185         case SAVEt_ITEM:                        /* normal string */
8186             sv = (SV*)POPPTR(ss,ix);
8187             TOPPTR(nss,ix) = sv_dup_inc(sv);
8188             sv = (SV*)POPPTR(ss,ix);
8189             TOPPTR(nss,ix) = sv_dup_inc(sv);
8190             break;
8191         case SAVEt_SV:                          /* scalar reference */
8192             sv = (SV*)POPPTR(ss,ix);
8193             TOPPTR(nss,ix) = sv_dup_inc(sv);
8194             gv = (GV*)POPPTR(ss,ix);
8195             TOPPTR(nss,ix) = gv_dup_inc(gv);
8196             break;
8197         case SAVEt_GENERIC_PVREF:               /* generic char* */
8198             c = (char*)POPPTR(ss,ix);
8199             TOPPTR(nss,ix) = pv_dup(c);
8200             ptr = POPPTR(ss,ix);
8201             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8202             break;
8203         case SAVEt_GENERIC_SVREF:               /* generic sv */
8204         case SAVEt_SVREF:                       /* scalar reference */
8205             sv = (SV*)POPPTR(ss,ix);
8206             TOPPTR(nss,ix) = sv_dup_inc(sv);
8207             ptr = POPPTR(ss,ix);
8208             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8209             break;
8210         case SAVEt_AV:                          /* array reference */
8211             av = (AV*)POPPTR(ss,ix);
8212             TOPPTR(nss,ix) = av_dup_inc(av);
8213             gv = (GV*)POPPTR(ss,ix);
8214             TOPPTR(nss,ix) = gv_dup(gv);
8215             break;
8216         case SAVEt_HV:                          /* hash reference */
8217             hv = (HV*)POPPTR(ss,ix);
8218             TOPPTR(nss,ix) = hv_dup_inc(hv);
8219             gv = (GV*)POPPTR(ss,ix);
8220             TOPPTR(nss,ix) = gv_dup(gv);
8221             break;
8222         case SAVEt_INT:                         /* int reference */
8223             ptr = POPPTR(ss,ix);
8224             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8225             intval = (int)POPINT(ss,ix);
8226             TOPINT(nss,ix) = intval;
8227             break;
8228         case SAVEt_LONG:                        /* long reference */
8229             ptr = POPPTR(ss,ix);
8230             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8231             longval = (long)POPLONG(ss,ix);
8232             TOPLONG(nss,ix) = longval;
8233             break;
8234         case SAVEt_I32:                         /* I32 reference */
8235         case SAVEt_I16:                         /* I16 reference */
8236         case SAVEt_I8:                          /* I8 reference */
8237             ptr = POPPTR(ss,ix);
8238             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8239             i = POPINT(ss,ix);
8240             TOPINT(nss,ix) = i;
8241             break;
8242         case SAVEt_IV:                          /* IV reference */
8243             ptr = POPPTR(ss,ix);
8244             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8245             iv = POPIV(ss,ix);
8246             TOPIV(nss,ix) = iv;
8247             break;
8248         case SAVEt_SPTR:                        /* SV* reference */
8249             ptr = POPPTR(ss,ix);
8250             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8251             sv = (SV*)POPPTR(ss,ix);
8252             TOPPTR(nss,ix) = sv_dup(sv);
8253             break;
8254         case SAVEt_VPTR:                        /* random* reference */
8255             ptr = POPPTR(ss,ix);
8256             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8257             ptr = POPPTR(ss,ix);
8258             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8259             break;
8260         case SAVEt_PPTR:                        /* char* reference */
8261             ptr = POPPTR(ss,ix);
8262             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8263             c = (char*)POPPTR(ss,ix);
8264             TOPPTR(nss,ix) = pv_dup(c);
8265             break;
8266         case SAVEt_HPTR:                        /* HV* reference */
8267             ptr = POPPTR(ss,ix);
8268             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8269             hv = (HV*)POPPTR(ss,ix);
8270             TOPPTR(nss,ix) = hv_dup(hv);
8271             break;
8272         case SAVEt_APTR:                        /* AV* reference */
8273             ptr = POPPTR(ss,ix);
8274             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8275             av = (AV*)POPPTR(ss,ix);
8276             TOPPTR(nss,ix) = av_dup(av);
8277             break;
8278         case SAVEt_NSTAB:
8279             gv = (GV*)POPPTR(ss,ix);
8280             TOPPTR(nss,ix) = gv_dup(gv);
8281             break;
8282         case SAVEt_GP:                          /* scalar reference */
8283             gp = (GP*)POPPTR(ss,ix);
8284             TOPPTR(nss,ix) = gp = gp_dup(gp);
8285             (void)GpREFCNT_inc(gp);
8286             gv = (GV*)POPPTR(ss,ix);
8287             TOPPTR(nss,ix) = gv_dup_inc(c);
8288             c = (char*)POPPTR(ss,ix);
8289             TOPPTR(nss,ix) = pv_dup(c);
8290             iv = POPIV(ss,ix);
8291             TOPIV(nss,ix) = iv;
8292             iv = POPIV(ss,ix);
8293             TOPIV(nss,ix) = iv;
8294             break;
8295         case SAVEt_FREESV:
8296             sv = (SV*)POPPTR(ss,ix);
8297             TOPPTR(nss,ix) = sv_dup_inc(sv);
8298             break;
8299         case SAVEt_FREEOP:
8300             ptr = POPPTR(ss,ix);
8301             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8302                 /* these are assumed to be refcounted properly */
8303                 switch (((OP*)ptr)->op_type) {
8304                 case OP_LEAVESUB:
8305                 case OP_LEAVESUBLV:
8306                 case OP_LEAVEEVAL:
8307                 case OP_LEAVE:
8308                 case OP_SCOPE:
8309                 case OP_LEAVEWRITE:
8310                     TOPPTR(nss,ix) = ptr;
8311                     o = (OP*)ptr;
8312                     OpREFCNT_inc(o);
8313                     break;
8314                 default:
8315                     TOPPTR(nss,ix) = Nullop;
8316                     break;
8317                 }
8318             }
8319             else
8320                 TOPPTR(nss,ix) = Nullop;
8321             break;
8322         case SAVEt_FREEPV:
8323             c = (char*)POPPTR(ss,ix);
8324             TOPPTR(nss,ix) = pv_dup_inc(c);
8325             break;
8326         case SAVEt_CLEARSV:
8327             longval = POPLONG(ss,ix);
8328             TOPLONG(nss,ix) = longval;
8329             break;
8330         case SAVEt_DELETE:
8331             hv = (HV*)POPPTR(ss,ix);
8332             TOPPTR(nss,ix) = hv_dup_inc(hv);
8333             c = (char*)POPPTR(ss,ix);
8334             TOPPTR(nss,ix) = pv_dup_inc(c);
8335             i = POPINT(ss,ix);
8336             TOPINT(nss,ix) = i;
8337             break;
8338         case SAVEt_DESTRUCTOR:
8339             ptr = POPPTR(ss,ix);
8340             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
8341             dptr = POPDPTR(ss,ix);
8342             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8343             break;
8344         case SAVEt_DESTRUCTOR_X:
8345             ptr = POPPTR(ss,ix);
8346             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
8347             dxptr = POPDXPTR(ss,ix);
8348             TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8349             break;
8350         case SAVEt_REGCONTEXT:
8351         case SAVEt_ALLOC:
8352             i = POPINT(ss,ix);
8353             TOPINT(nss,ix) = i;
8354             ix -= i;
8355             break;
8356         case SAVEt_STACK_POS:           /* Position on Perl stack */
8357             i = POPINT(ss,ix);
8358             TOPINT(nss,ix) = i;
8359             break;
8360         case SAVEt_AELEM:               /* array element */
8361             sv = (SV*)POPPTR(ss,ix);
8362             TOPPTR(nss,ix) = sv_dup_inc(sv);
8363             i = POPINT(ss,ix);
8364             TOPINT(nss,ix) = i;
8365             av = (AV*)POPPTR(ss,ix);
8366             TOPPTR(nss,ix) = av_dup_inc(av);
8367             break;
8368         case SAVEt_HELEM:               /* hash element */
8369             sv = (SV*)POPPTR(ss,ix);
8370             TOPPTR(nss,ix) = sv_dup_inc(sv);
8371             sv = (SV*)POPPTR(ss,ix);
8372             TOPPTR(nss,ix) = sv_dup_inc(sv);
8373             hv = (HV*)POPPTR(ss,ix);
8374             TOPPTR(nss,ix) = hv_dup_inc(hv);
8375             break;
8376         case SAVEt_OP:
8377             ptr = POPPTR(ss,ix);
8378             TOPPTR(nss,ix) = ptr;
8379             break;
8380         case SAVEt_HINTS:
8381             i = POPINT(ss,ix);
8382             TOPINT(nss,ix) = i;
8383             break;
8384         case SAVEt_COMPPAD:
8385             av = (AV*)POPPTR(ss,ix);
8386             TOPPTR(nss,ix) = av_dup(av);
8387             break;
8388         case SAVEt_PADSV:
8389             longval = (long)POPLONG(ss,ix);
8390             TOPLONG(nss,ix) = longval;
8391             ptr = POPPTR(ss,ix);
8392             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8393             sv = (SV*)POPPTR(ss,ix);
8394             TOPPTR(nss,ix) = sv_dup(sv);
8395             break;
8396         default:
8397             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8398         }
8399     }
8400
8401     return nss;
8402 }
8403
8404 #ifdef PERL_OBJECT
8405 #include "XSUB.h"
8406 #endif
8407
8408 PerlInterpreter *
8409 perl_clone(PerlInterpreter *proto_perl, UV flags)
8410 {
8411 #ifdef PERL_OBJECT
8412     CPerlObj *pPerl = (CPerlObj*)proto_perl;
8413 #endif
8414
8415 #ifdef PERL_IMPLICIT_SYS
8416     return perl_clone_using(proto_perl, flags,
8417                             proto_perl->IMem,
8418                             proto_perl->IMemShared,
8419                             proto_perl->IMemParse,
8420                             proto_perl->IEnv,
8421                             proto_perl->IStdIO,
8422                             proto_perl->ILIO,
8423                             proto_perl->IDir,
8424                             proto_perl->ISock,
8425                             proto_perl->IProc);
8426 }
8427
8428 PerlInterpreter *
8429 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8430                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
8431                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8432                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8433                  struct IPerlDir* ipD, struct IPerlSock* ipS,
8434                  struct IPerlProc* ipP)
8435 {
8436     /* XXX many of the string copies here can be optimized if they're
8437      * constants; they need to be allocated as common memory and just
8438      * their pointers copied. */
8439
8440     IV i;
8441 #  ifdef PERL_OBJECT
8442     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8443                                         ipD, ipS, ipP);
8444     PERL_SET_THX(pPerl);
8445 #  else         /* !PERL_OBJECT */
8446     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8447     PERL_SET_THX(my_perl);
8448
8449 #    ifdef DEBUGGING
8450     memset(my_perl, 0xab, sizeof(PerlInterpreter));
8451     PL_markstack = 0;
8452     PL_scopestack = 0;
8453     PL_savestack = 0;
8454     PL_retstack = 0;
8455     PL_sig_pending = 0;
8456 #    else       /* !DEBUGGING */
8457     Zero(my_perl, 1, PerlInterpreter);
8458 #    endif      /* DEBUGGING */
8459
8460     /* host pointers */
8461     PL_Mem              = ipM;
8462     PL_MemShared        = ipMS;
8463     PL_MemParse         = ipMP;
8464     PL_Env              = ipE;
8465     PL_StdIO            = ipStd;
8466     PL_LIO              = ipLIO;
8467     PL_Dir              = ipD;
8468     PL_Sock             = ipS;
8469     PL_Proc             = ipP;
8470 #  endif        /* PERL_OBJECT */
8471 #else           /* !PERL_IMPLICIT_SYS */
8472     IV i;
8473     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8474     PERL_SET_THX(my_perl);
8475
8476 #    ifdef DEBUGGING
8477     memset(my_perl, 0xab, sizeof(PerlInterpreter));
8478     PL_markstack = 0;
8479     PL_scopestack = 0;
8480     PL_savestack = 0;
8481     PL_retstack = 0;
8482     PL_sig_pending = 0;
8483 #    else       /* !DEBUGGING */
8484     Zero(my_perl, 1, PerlInterpreter);
8485 #    endif      /* DEBUGGING */
8486 #endif          /* PERL_IMPLICIT_SYS */
8487
8488     /* arena roots */
8489     PL_xiv_arenaroot    = NULL;
8490     PL_xiv_root         = NULL;
8491     PL_xnv_arenaroot    = NULL;
8492     PL_xnv_root         = NULL;
8493     PL_xrv_arenaroot    = NULL;
8494     PL_xrv_root         = NULL;
8495     PL_xpv_arenaroot    = NULL;
8496     PL_xpv_root         = NULL;
8497     PL_xpviv_arenaroot  = NULL;
8498     PL_xpviv_root       = NULL;
8499     PL_xpvnv_arenaroot  = NULL;
8500     PL_xpvnv_root       = NULL;
8501     PL_xpvcv_arenaroot  = NULL;
8502     PL_xpvcv_root       = NULL;
8503     PL_xpvav_arenaroot  = NULL;
8504     PL_xpvav_root       = NULL;
8505     PL_xpvhv_arenaroot  = NULL;
8506     PL_xpvhv_root       = NULL;
8507     PL_xpvmg_arenaroot  = NULL;
8508     PL_xpvmg_root       = NULL;
8509     PL_xpvlv_arenaroot  = NULL;
8510     PL_xpvlv_root       = NULL;
8511     PL_xpvbm_arenaroot  = NULL;
8512     PL_xpvbm_root       = NULL;
8513     PL_he_arenaroot     = NULL;
8514     PL_he_root          = NULL;
8515     PL_nice_chunk       = NULL;
8516     PL_nice_chunk_size  = 0;
8517     PL_sv_count         = 0;
8518     PL_sv_objcount      = 0;
8519     PL_sv_root          = Nullsv;
8520     PL_sv_arenaroot     = Nullsv;
8521
8522     PL_debug            = proto_perl->Idebug;
8523
8524     /* create SV map for pointer relocation */
8525     PL_ptr_table = ptr_table_new();
8526
8527     /* initialize these special pointers as early as possible */
8528     SvANY(&PL_sv_undef)         = NULL;
8529     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
8530     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
8531     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8532
8533 #ifdef PERL_OBJECT
8534     SvUPGRADE(&PL_sv_no, SVt_PVNV);
8535 #else
8536     SvANY(&PL_sv_no)            = new_XPVNV();
8537 #endif
8538     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
8539     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8540     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
8541     SvCUR(&PL_sv_no)            = 0;
8542     SvLEN(&PL_sv_no)            = 1;
8543     SvNVX(&PL_sv_no)            = 0;
8544     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8545
8546 #ifdef PERL_OBJECT
8547     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8548 #else
8549     SvANY(&PL_sv_yes)           = new_XPVNV();
8550 #endif
8551     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
8552     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8553     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
8554     SvCUR(&PL_sv_yes)           = 1;
8555     SvLEN(&PL_sv_yes)           = 2;
8556     SvNVX(&PL_sv_yes)           = 1;
8557     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8558
8559     /* create shared string table */
8560     PL_strtab           = newHV();
8561     HvSHAREKEYS_off(PL_strtab);
8562     hv_ksplit(PL_strtab, 512);
8563     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8564
8565     PL_compiling                = proto_perl->Icompiling;
8566     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
8567     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
8568     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8569     if (!specialWARN(PL_compiling.cop_warnings))
8570         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8571     if (!specialCopIO(PL_compiling.cop_io))
8572         PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8573     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8574
8575     /* pseudo environmental stuff */
8576     PL_origargc         = proto_perl->Iorigargc;
8577     i = PL_origargc;
8578     New(0, PL_origargv, i+1, char*);
8579     PL_origargv[i] = '\0';
8580     while (i-- > 0) {
8581         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
8582     }
8583     PL_envgv            = gv_dup(proto_perl->Ienvgv);
8584     PL_incgv            = gv_dup(proto_perl->Iincgv);
8585     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
8586     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
8587     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
8588     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
8589
8590     /* switches */
8591     PL_minus_c          = proto_perl->Iminus_c;
8592     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
8593     PL_localpatches     = proto_perl->Ilocalpatches;
8594     PL_splitstr         = proto_perl->Isplitstr;
8595     PL_preprocess       = proto_perl->Ipreprocess;
8596     PL_minus_n          = proto_perl->Iminus_n;
8597     PL_minus_p          = proto_perl->Iminus_p;
8598     PL_minus_l          = proto_perl->Iminus_l;
8599     PL_minus_a          = proto_perl->Iminus_a;
8600     PL_minus_F          = proto_perl->Iminus_F;
8601     PL_doswitches       = proto_perl->Idoswitches;
8602     PL_dowarn           = proto_perl->Idowarn;
8603     PL_doextract        = proto_perl->Idoextract;
8604     PL_sawampersand     = proto_perl->Isawampersand;
8605     PL_unsafe           = proto_perl->Iunsafe;
8606     PL_inplace          = SAVEPV(proto_perl->Iinplace);
8607     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
8608     PL_perldb           = proto_perl->Iperldb;
8609     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8610
8611     /* magical thingies */
8612     /* XXX time(&PL_basetime) when asked for? */
8613     PL_basetime         = proto_perl->Ibasetime;
8614     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
8615
8616     PL_maxsysfd         = proto_perl->Imaxsysfd;
8617     PL_multiline        = proto_perl->Imultiline;
8618     PL_statusvalue      = proto_perl->Istatusvalue;
8619 #ifdef VMS
8620     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
8621 #endif
8622
8623     /* shortcuts to various I/O objects */
8624     PL_stdingv          = gv_dup(proto_perl->Istdingv);
8625     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
8626     PL_defgv            = gv_dup(proto_perl->Idefgv);
8627     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
8628     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
8629     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
8630
8631     /* shortcuts to regexp stuff */
8632     PL_replgv           = gv_dup(proto_perl->Ireplgv);
8633
8634     /* shortcuts to misc objects */
8635     PL_errgv            = gv_dup(proto_perl->Ierrgv);
8636
8637     /* shortcuts to debugging objects */
8638     PL_DBgv             = gv_dup(proto_perl->IDBgv);
8639     PL_DBline           = gv_dup(proto_perl->IDBline);
8640     PL_DBsub            = gv_dup(proto_perl->IDBsub);
8641     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
8642     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
8643     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
8644     PL_lineary          = av_dup(proto_perl->Ilineary);
8645     PL_dbargs           = av_dup(proto_perl->Idbargs);
8646
8647     /* symbol tables */
8648     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
8649     PL_curstash         = hv_dup(proto_perl->Tcurstash);
8650     PL_debstash         = hv_dup(proto_perl->Idebstash);
8651     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
8652     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
8653
8654     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
8655     PL_endav            = av_dup_inc(proto_perl->Iendav);
8656     PL_checkav          = av_dup_inc(proto_perl->Icheckav);
8657     PL_initav           = av_dup_inc(proto_perl->Iinitav);
8658
8659     PL_sub_generation   = proto_perl->Isub_generation;
8660
8661     /* funky return mechanisms */
8662     PL_forkprocess      = proto_perl->Iforkprocess;
8663
8664     /* subprocess state */
8665     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
8666
8667     /* internal state */
8668     PL_tainting         = proto_perl->Itainting;
8669     PL_maxo             = proto_perl->Imaxo;
8670     if (proto_perl->Iop_mask)
8671         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8672     else
8673         PL_op_mask      = Nullch;
8674
8675     /* current interpreter roots */
8676     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
8677     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
8678     PL_main_start       = proto_perl->Imain_start;
8679     PL_eval_root        = proto_perl->Ieval_root;
8680     PL_eval_start       = proto_perl->Ieval_start;
8681
8682     /* runtime control stuff */
8683     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8684     PL_copline          = proto_perl->Icopline;
8685
8686     PL_filemode         = proto_perl->Ifilemode;
8687     PL_lastfd           = proto_perl->Ilastfd;
8688     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
8689     PL_Argv             = NULL;
8690     PL_Cmd              = Nullch;
8691     PL_gensym           = proto_perl->Igensym;
8692     PL_preambled        = proto_perl->Ipreambled;
8693     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
8694     PL_laststatval      = proto_perl->Ilaststatval;
8695     PL_laststype        = proto_perl->Ilaststype;
8696     PL_mess_sv          = Nullsv;
8697
8698     PL_ors_sv           = sv_dup_inc(proto_perl->Iors_sv);
8699     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
8700
8701     /* interpreter atexit processing */
8702     PL_exitlistlen      = proto_perl->Iexitlistlen;
8703     if (PL_exitlistlen) {
8704         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8705         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8706     }
8707     else
8708         PL_exitlist     = (PerlExitListEntry*)NULL;
8709     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
8710
8711     PL_profiledata      = NULL;
8712     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
8713     /* PL_rsfp_filters entries have fake IoDIRP() */
8714     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
8715
8716     PL_compcv                   = cv_dup(proto_perl->Icompcv);
8717     PL_comppad                  = av_dup(proto_perl->Icomppad);
8718     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
8719     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
8720     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
8721     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
8722                                                         proto_perl->Tcurpad);
8723
8724 #ifdef HAVE_INTERP_INTERN
8725     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8726 #endif
8727
8728     /* more statics moved here */
8729     PL_generation       = proto_perl->Igeneration;
8730     PL_DBcv             = cv_dup(proto_perl->IDBcv);
8731
8732     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
8733     PL_in_clean_all     = proto_perl->Iin_clean_all;
8734
8735     PL_uid              = proto_perl->Iuid;
8736     PL_euid             = proto_perl->Ieuid;
8737     PL_gid              = proto_perl->Igid;
8738     PL_egid             = proto_perl->Iegid;
8739     PL_nomemok          = proto_perl->Inomemok;
8740     PL_an               = proto_perl->Ian;
8741     PL_cop_seqmax       = proto_perl->Icop_seqmax;
8742     PL_op_seqmax        = proto_perl->Iop_seqmax;
8743     PL_evalseq          = proto_perl->Ievalseq;
8744     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
8745     PL_origalen         = proto_perl->Iorigalen;
8746     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
8747     PL_osname           = SAVEPV(proto_perl->Iosname);
8748     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
8749     PL_sighandlerp      = proto_perl->Isighandlerp;
8750
8751
8752     PL_runops           = proto_perl->Irunops;
8753
8754     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8755
8756 #ifdef CSH
8757     PL_cshlen           = proto_perl->Icshlen;
8758     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8759 #endif
8760
8761     PL_lex_state        = proto_perl->Ilex_state;
8762     PL_lex_defer        = proto_perl->Ilex_defer;
8763     PL_lex_expect       = proto_perl->Ilex_expect;
8764     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
8765     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
8766     PL_lex_starts       = proto_perl->Ilex_starts;
8767     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
8768     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
8769     PL_lex_op           = proto_perl->Ilex_op;
8770     PL_lex_inpat        = proto_perl->Ilex_inpat;
8771     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
8772     PL_lex_brackets     = proto_perl->Ilex_brackets;
8773     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8774     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
8775     PL_lex_casemods     = proto_perl->Ilex_casemods;
8776     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8777     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
8778
8779     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8780     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8781     PL_nexttoke         = proto_perl->Inexttoke;
8782
8783     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
8784     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8785     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8786     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8787     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8788     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8789     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8790     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8791     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8792     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8793     PL_pending_ident    = proto_perl->Ipending_ident;
8794     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
8795
8796     PL_expect           = proto_perl->Iexpect;
8797
8798     PL_multi_start      = proto_perl->Imulti_start;
8799     PL_multi_end        = proto_perl->Imulti_end;
8800     PL_multi_open       = proto_perl->Imulti_open;
8801     PL_multi_close      = proto_perl->Imulti_close;
8802
8803     PL_error_count      = proto_perl->Ierror_count;
8804     PL_subline          = proto_perl->Isubline;
8805     PL_subname          = sv_dup_inc(proto_perl->Isubname);
8806
8807     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
8808     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
8809     PL_padix                    = proto_perl->Ipadix;
8810     PL_padix_floor              = proto_perl->Ipadix_floor;
8811     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
8812
8813     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8814     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8815     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8816     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8817     PL_last_lop_op      = proto_perl->Ilast_lop_op;
8818     PL_in_my            = proto_perl->Iin_my;
8819     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
8820 #ifdef FCRYPT
8821     PL_cryptseen        = proto_perl->Icryptseen;
8822 #endif
8823
8824     PL_hints            = proto_perl->Ihints;
8825
8826     PL_amagic_generation        = proto_perl->Iamagic_generation;
8827
8828 #ifdef USE_LOCALE_COLLATE
8829     PL_collation_ix     = proto_perl->Icollation_ix;
8830     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
8831     PL_collation_standard       = proto_perl->Icollation_standard;
8832     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
8833     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
8834 #endif /* USE_LOCALE_COLLATE */
8835
8836 #ifdef USE_LOCALE_NUMERIC
8837     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
8838     PL_numeric_standard = proto_perl->Inumeric_standard;
8839     PL_numeric_local    = proto_perl->Inumeric_local;
8840     PL_numeric_radix    = proto_perl->Inumeric_radix;
8841 #endif /* !USE_LOCALE_NUMERIC */
8842
8843     /* utf8 character classes */
8844     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
8845     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
8846     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
8847     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
8848     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
8849     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
8850     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
8851     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
8852     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
8853     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
8854     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
8855     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
8856     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
8857     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
8858     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
8859     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
8860     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
8861
8862     /* swatch cache */
8863     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
8864     PL_last_swash_klen  = 0;
8865     PL_last_swash_key[0]= '\0';
8866     PL_last_swash_tmps  = (U8*)NULL;
8867     PL_last_swash_slen  = 0;
8868
8869     /* perly.c globals */
8870     PL_yydebug          = proto_perl->Iyydebug;
8871     PL_yynerrs          = proto_perl->Iyynerrs;
8872     PL_yyerrflag        = proto_perl->Iyyerrflag;
8873     PL_yychar           = proto_perl->Iyychar;
8874     PL_yyval            = proto_perl->Iyyval;
8875     PL_yylval           = proto_perl->Iyylval;
8876
8877     PL_glob_index       = proto_perl->Iglob_index;
8878     PL_srand_called     = proto_perl->Isrand_called;
8879     PL_uudmap['M']      = 0;            /* reinits on demand */
8880     PL_bitcount         = Nullch;       /* reinits on demand */
8881
8882     if (proto_perl->Ipsig_pend) {
8883         Newz(0, PL_psig_pend, SIG_SIZE, int);
8884     }
8885     else {
8886         PL_psig_pend    = (int*)NULL;
8887     }
8888
8889     if (proto_perl->Ipsig_ptr) {
8890         Newz(0, PL_psig_ptr,  SIG_SIZE, SV*);
8891         Newz(0, PL_psig_name, SIG_SIZE, SV*);
8892         for (i = 1; i < SIG_SIZE; i++) {
8893             PL_psig_ptr[i]  = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8894             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8895         }
8896     }
8897     else {
8898         PL_psig_ptr     = (SV**)NULL;
8899         PL_psig_name    = (SV**)NULL;
8900     }
8901
8902     /* thrdvar.h stuff */
8903
8904     if (flags & 1) {
8905         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8906         PL_tmps_ix              = proto_perl->Ttmps_ix;
8907         PL_tmps_max             = proto_perl->Ttmps_max;
8908         PL_tmps_floor           = proto_perl->Ttmps_floor;
8909         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8910         i = 0;
8911         while (i <= PL_tmps_ix) {
8912             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8913             ++i;
8914         }
8915
8916         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8917         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8918         Newz(54, PL_markstack, i, I32);
8919         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
8920                                                   - proto_perl->Tmarkstack);
8921         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
8922                                                   - proto_perl->Tmarkstack);
8923         Copy(proto_perl->Tmarkstack, PL_markstack,
8924              PL_markstack_ptr - PL_markstack + 1, I32);
8925
8926         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8927          * NOTE: unlike the others! */
8928         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
8929         PL_scopestack_max       = proto_perl->Tscopestack_max;
8930         Newz(54, PL_scopestack, PL_scopestack_max, I32);
8931         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8932
8933         /* next push_return() sets PL_retstack[PL_retstack_ix]
8934          * NOTE: unlike the others! */
8935         PL_retstack_ix          = proto_perl->Tretstack_ix;
8936         PL_retstack_max         = proto_perl->Tretstack_max;
8937         Newz(54, PL_retstack, PL_retstack_max, OP*);
8938         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8939
8940         /* NOTE: si_dup() looks at PL_markstack */
8941         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
8942
8943         /* PL_curstack          = PL_curstackinfo->si_stack; */
8944         PL_curstack             = av_dup(proto_perl->Tcurstack);
8945         PL_mainstack            = av_dup(proto_perl->Tmainstack);
8946
8947         /* next PUSHs() etc. set *(PL_stack_sp+1) */
8948         PL_stack_base           = AvARRAY(PL_curstack);
8949         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
8950                                                    - proto_perl->Tstack_base);
8951         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
8952
8953         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8954          * NOTE: unlike the others! */
8955         PL_savestack_ix         = proto_perl->Tsavestack_ix;
8956         PL_savestack_max        = proto_perl->Tsavestack_max;
8957         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8958         PL_savestack            = ss_dup(proto_perl);
8959     }
8960     else {
8961         init_stacks();
8962         ENTER;                  /* perl_destruct() wants to LEAVE; */
8963     }
8964
8965     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
8966     PL_top_env          = &PL_start_env;
8967
8968     PL_op               = proto_perl->Top;
8969
8970     PL_Sv               = Nullsv;
8971     PL_Xpv              = (XPV*)NULL;
8972     PL_na               = proto_perl->Tna;
8973
8974     PL_statbuf          = proto_perl->Tstatbuf;
8975     PL_statcache        = proto_perl->Tstatcache;
8976     PL_statgv           = gv_dup(proto_perl->Tstatgv);
8977     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
8978 #ifdef HAS_TIMES
8979     PL_timesbuf         = proto_perl->Ttimesbuf;
8980 #endif
8981
8982     PL_tainted          = proto_perl->Ttainted;
8983     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
8984     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
8985     PL_rs               = sv_dup_inc(proto_perl->Trs);
8986     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
8987     PL_ofs_sv           = sv_dup_inc(proto_perl->Tofs_sv);
8988     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
8989     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
8990     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
8991     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
8992     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
8993
8994     PL_restartop        = proto_perl->Trestartop;
8995     PL_in_eval          = proto_perl->Tin_eval;
8996     PL_delaymagic       = proto_perl->Tdelaymagic;
8997     PL_dirty            = proto_perl->Tdirty;
8998     PL_localizing       = proto_perl->Tlocalizing;
8999
9000 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9001     PL_protect          = proto_perl->Tprotect;
9002 #endif
9003     PL_errors           = sv_dup_inc(proto_perl->Terrors);
9004     PL_av_fetch_sv      = Nullsv;
9005     PL_hv_fetch_sv      = Nullsv;
9006     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
9007     PL_modcount         = proto_perl->Tmodcount;
9008     PL_lastgotoprobe    = Nullop;
9009     PL_dumpindent       = proto_perl->Tdumpindent;
9010
9011     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9012     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
9013     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
9014     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
9015     PL_sortcxix         = proto_perl->Tsortcxix;
9016     PL_efloatbuf        = Nullch;               /* reinits on demand */
9017     PL_efloatsize       = 0;                    /* reinits on demand */
9018
9019     /* regex stuff */
9020
9021     PL_screamfirst      = NULL;
9022     PL_screamnext       = NULL;
9023     PL_maxscream        = -1;                   /* reinits on demand */
9024     PL_lastscream       = Nullsv;
9025
9026     PL_watchaddr        = NULL;
9027     PL_watchok          = Nullch;
9028
9029     PL_regdummy         = proto_perl->Tregdummy;
9030     PL_regcomp_parse    = Nullch;
9031     PL_regxend          = Nullch;
9032     PL_regcode          = (regnode*)NULL;
9033     PL_regnaughty       = 0;
9034     PL_regsawback       = 0;
9035     PL_regprecomp       = Nullch;
9036     PL_regnpar          = 0;
9037     PL_regsize          = 0;
9038     PL_regflags         = 0;
9039     PL_regseen          = 0;
9040     PL_seen_zerolen     = 0;
9041     PL_seen_evals       = 0;
9042     PL_regcomp_rx       = (regexp*)NULL;
9043     PL_extralen         = 0;
9044     PL_colorset         = 0;            /* reinits PL_colors[] */
9045     /*PL_colors[6]      = {0,0,0,0,0,0};*/
9046     PL_reg_whilem_seen  = 0;
9047     PL_reginput         = Nullch;
9048     PL_regbol           = Nullch;
9049     PL_regeol           = Nullch;
9050     PL_regstartp        = (I32*)NULL;
9051     PL_regendp          = (I32*)NULL;
9052     PL_reglastparen     = (U32*)NULL;
9053     PL_regtill          = Nullch;
9054     PL_regprev          = '\n';
9055     PL_reg_start_tmp    = (char**)NULL;
9056     PL_reg_start_tmpl   = 0;
9057     PL_regdata          = (struct reg_data*)NULL;
9058     PL_bostr            = Nullch;
9059     PL_reg_flags        = 0;
9060     PL_reg_eval_set     = 0;
9061     PL_regnarrate       = 0;
9062     PL_regprogram       = (regnode*)NULL;
9063     PL_regindent        = 0;
9064     PL_regcc            = (CURCUR*)NULL;
9065     PL_reg_call_cc      = (struct re_cc_state*)NULL;
9066     PL_reg_re           = (regexp*)NULL;
9067     PL_reg_ganch        = Nullch;
9068     PL_reg_sv           = Nullsv;
9069     PL_reg_magic        = (MAGIC*)NULL;
9070     PL_reg_oldpos       = 0;
9071     PL_reg_oldcurpm     = (PMOP*)NULL;
9072     PL_reg_curpm        = (PMOP*)NULL;
9073     PL_reg_oldsaved     = Nullch;
9074     PL_reg_oldsavedlen  = 0;
9075     PL_reg_maxiter      = 0;
9076     PL_reg_leftiter     = 0;
9077     PL_reg_poscache     = Nullch;
9078     PL_reg_poscache_size= 0;
9079
9080     /* RE engine - function pointers */
9081     PL_regcompp         = proto_perl->Tregcompp;
9082     PL_regexecp         = proto_perl->Tregexecp;
9083     PL_regint_start     = proto_perl->Tregint_start;
9084     PL_regint_string    = proto_perl->Tregint_string;
9085     PL_regfree          = proto_perl->Tregfree;
9086
9087     PL_reginterp_cnt    = 0;
9088     PL_reg_starttry     = 0;
9089
9090 #ifdef PERL_OBJECT
9091     return (PerlInterpreter*)pPerl;
9092 #else
9093     return my_perl;
9094 #endif
9095 }
9096
9097 #else   /* !USE_ITHREADS */
9098
9099 #ifdef PERL_OBJECT
9100 #include "XSUB.h"
9101 #endif
9102
9103 #endif /* USE_ITHREADS */
9104
9105 static void
9106 do_report_used(pTHXo_ SV *sv)
9107 {
9108     if (SvTYPE(sv) != SVTYPEMASK) {
9109         PerlIO_printf(Perl_debug_log, "****\n");
9110         sv_dump(sv);
9111     }
9112 }
9113
9114 static void
9115 do_clean_objs(pTHXo_ SV *sv)
9116 {
9117     SV* rv;
9118
9119     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9120         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9121         if (SvWEAKREF(sv)) {
9122             sv_del_backref(sv);
9123             SvWEAKREF_off(sv);
9124             SvRV(sv) = 0;
9125         } else {
9126             SvROK_off(sv);
9127             SvRV(sv) = 0;
9128             SvREFCNT_dec(rv);
9129         }
9130     }
9131
9132     /* XXX Might want to check arrays, etc. */
9133 }
9134
9135 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9136 static void
9137 do_clean_named_objs(pTHXo_ SV *sv)
9138 {
9139     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9140         if ( SvOBJECT(GvSV(sv)) ||
9141              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9142              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9143              (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9144              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9145         {
9146             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9147             SvREFCNT_dec(sv);
9148         }
9149     }
9150 }
9151 #endif
9152
9153 static void
9154 do_clean_all(pTHXo_ SV *sv)
9155 {
9156     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9157     SvFLAGS(sv) |= SVf_BREAK;
9158     SvREFCNT_dec(sv);
9159 }
9160