sv.c

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