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