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