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