sv.c

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