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