sv.c

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