sv.c

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