sv.c

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