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