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