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