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