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