sv.c

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