sv.c

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