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