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