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             s++;
2014         }
2015         sawinf = 1;
2016     }
2017     else
2018         return 0;
2019
2020     if (sawinf)
2021         numtype = IS_NUMBER_INFINITY;
2022     else {
2023         /* we can have an optional exponent part */
2024         if (*s == 'e' || *s == 'E') {
2025             numtype &= ~IS_NUMBER_NEG;
2026             numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
2027             s++;
2028             if (*s == '+' || *s == '-')
2029                 s++;
2030             if (isDIGIT(*s)) {
2031                 do {
2032                     s++;
2033                 } while (isDIGIT(*s));
2034             }
2035             else
2036                 return 0;
2037         }
2038     }
2039     while (isSPACE(*s))
2040         s++;
2041     if (s >= send)
2042         return numtype;
2043     if (len == 10 && memEQ(sbegin, "0 but true", 10))
2044         return IS_NUMBER_TO_INT_BY_ATOL;
2045     return 0;
2046 }
2047
2048 char *
2049 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2050 {
2051     STRLEN n_a;
2052     return sv_2pv(sv, &n_a);
2053 }
2054
2055 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2056 static char *
2057 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2058 {
2059     char *ptr = buf + TYPE_CHARS(UV);
2060     char *ebuf = ptr;
2061     int sign;
2062
2063     if (is_uv)
2064         sign = 0;
2065     else if (iv >= 0) {
2066         uv = iv;
2067         sign = 0;
2068     } else {
2069         uv = -iv;
2070         sign = 1;
2071     }
2072     do {
2073         *--ptr = '0' + (uv % 10);
2074     } while (uv /= 10);
2075     if (sign)
2076         *--ptr = '-';
2077     *peob = ebuf;
2078     return ptr;
2079 }
2080
2081 char *
2082 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2083 {
2084     register char *s;
2085     int olderrno;
2086     SV *tsv;
2087     char tbuf[64];      /* Must fit sprintf/Gconvert of longest IV/NV */
2088     char *tmpbuf = tbuf;
2089
2090     if (!sv) {
2091         *lp = 0;
2092         return "";
2093     }
2094     if (SvGMAGICAL(sv)) {
2095         mg_get(sv);
2096         if (SvPOKp(sv)) {
2097             *lp = SvCUR(sv);
2098             return SvPVX(sv);
2099         }
2100         if (SvIOKp(sv)) {
2101             if (SvIsUV(sv))
2102                 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2103             else
2104                 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2105             tsv = Nullsv;
2106             goto tokensave;
2107         }
2108         if (SvNOKp(sv)) {
2109             Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2110             tsv = Nullsv;
2111             goto tokensave;
2112         }
2113         if (!SvROK(sv)) {
2114             if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2115                 dTHR;
2116                 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2117                     report_uninit();
2118             }
2119             *lp = 0;
2120             return "";
2121         }
2122     }
2123     if (SvTHINKFIRST(sv)) {
2124         if (SvROK(sv)) {
2125             SV* tmpstr;
2126             if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2127                     (SvRV(tmpstr) != SvRV(sv)))
2128                 return SvPV(tmpstr,*lp);
2129             sv = (SV*)SvRV(sv);
2130             if (!sv)
2131                 s = "NULLREF";
2132             else {
2133                 MAGIC *mg;
2134
2135                 switch (SvTYPE(sv)) {
2136                 case SVt_PVMG:
2137                     if ( ((SvFLAGS(sv) &
2138                            (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2139                           == (SVs_OBJECT|SVs_RMG))
2140                          && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2141                          && (mg = mg_find(sv, 'r'))) {
2142                         dTHR;
2143                         regexp *re = (regexp *)mg->mg_obj;
2144
2145                         if (!mg->mg_ptr) {
2146                             char *fptr = "msix";
2147                             char reflags[6];
2148                             char ch;
2149                             int left = 0;
2150                             int right = 4;
2151                             U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2152
2153                             while((ch = *fptr++)) {
2154                                 if(reganch & 1) {
2155                                     reflags[left++] = ch;
2156                                 }
2157                                 else {
2158                                     reflags[right--] = ch;
2159                                 }
2160                                 reganch >>= 1;
2161                             }
2162                             if(left != 4) {
2163                                 reflags[left] = '-';
2164                                 left = 5;
2165                             }
2166
2167                             mg->mg_len = re->prelen + 4 + left;
2168                             New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2169                             Copy("(?", mg->mg_ptr, 2, char);
2170                             Copy(reflags, mg->mg_ptr+2, left, char);
2171                             Copy(":", mg->mg_ptr+left+2, 1, char);
2172                             Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2173                             mg->mg_ptr[mg->mg_len - 1] = ')';
2174                             mg->mg_ptr[mg->mg_len] = 0;
2175                         }
2176                         PL_reginterp_cnt += re->program[0].next_off;
2177                         *lp = mg->mg_len;
2178                         return mg->mg_ptr;
2179                     }
2180                                         /* Fall through */
2181                 case SVt_NULL:
2182                 case SVt_IV:
2183                 case SVt_NV:
2184                 case SVt_RV:
2185                 case SVt_PV:
2186                 case SVt_PVIV:
2187                 case SVt_PVNV:
2188                 case SVt_PVBM:  if (SvROK(sv))
2189                                     s = "REF";
2190                                 else
2191                                     s = "SCALAR";               break;
2192                 case SVt_PVLV:  s = "LVALUE";                   break;
2193                 case SVt_PVAV:  s = "ARRAY";                    break;
2194                 case SVt_PVHV:  s = "HASH";                     break;
2195                 case SVt_PVCV:  s = "CODE";                     break;
2196                 case SVt_PVGV:  s = "GLOB";                     break;
2197                 case SVt_PVFM:  s = "FORMAT";                   break;
2198                 case SVt_PVIO:  s = "IO";                       break;
2199                 default:        s = "UNKNOWN";                  break;
2200                 }
2201                 tsv = NEWSV(0,0);
2202                 if (SvOBJECT(sv))
2203                     Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2204                 else
2205                     sv_setpv(tsv, s);
2206                 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2207                 goto tokensaveref;
2208             }
2209             *lp = strlen(s);
2210             return s;
2211         }
2212         if (SvREADONLY(sv) && !SvOK(sv)) {
2213             dTHR;
2214             if (ckWARN(WARN_UNINITIALIZED))
2215                 report_uninit();
2216             *lp = 0;
2217             return "";
2218         }
2219     }
2220     if (SvNOKp(sv)) {                   /* See note in sv_2uv() */
2221         /* XXXX 64-bit?  IV may have better precision... */
2222         /* I tried changing this to be 64-bit-aware and
2223          * the t/op/numconvert.t became very, very, angry.
2224          * --jhi Sep 1999 */
2225         if (SvTYPE(sv) < SVt_PVNV)
2226             sv_upgrade(sv, SVt_PVNV);
2227         /* The +20 is pure guesswork.  Configure test needed. --jhi */
2228         SvGROW(sv, NV_DIG + 20);
2229         s = SvPVX(sv);
2230         olderrno = errno;       /* some Xenix systems wipe out errno here */
2231 #ifdef apollo
2232         if (SvNVX(sv) == 0.0)
2233             (void)strcpy(s,"0");
2234         else
2235 #endif /*apollo*/
2236         {
2237             Gconvert(SvNVX(sv), NV_DIG, 0, s);
2238         }
2239         errno = olderrno;
2240 #ifdef FIXNEGATIVEZERO
2241         if (*s == '-' && s[1] == '0' && !s[2])
2242             strcpy(s,"0");
2243 #endif
2244         while (*s) s++;
2245 #ifdef hcx
2246         if (s[-1] == '.')
2247             *--s = '\0';
2248 #endif
2249     }
2250     else if (SvIOKp(sv)) {
2251         U32 isIOK = SvIOK(sv);
2252         U32 isUIOK = SvIsUV(sv);
2253         char buf[TYPE_CHARS(UV)];
2254         char *ebuf, *ptr;
2255
2256         if (SvTYPE(sv) < SVt_PVIV)
2257             sv_upgrade(sv, SVt_PVIV);
2258         if (isUIOK)
2259             ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2260         else
2261             ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2262         SvGROW(sv, ebuf - ptr + 1);     /* inlined from sv_setpvn */
2263         Move(ptr,SvPVX(sv),ebuf - ptr,char);
2264         SvCUR_set(sv, ebuf - ptr);
2265         s = SvEND(sv);
2266         *s = '\0';
2267         if (isIOK)
2268             SvIOK_on(sv);
2269         else
2270             SvIOKp_on(sv);
2271         if (isUIOK)
2272             SvIsUV_on(sv);
2273         SvPOK_on(sv);
2274     }
2275     else {
2276         dTHR;
2277         if (ckWARN(WARN_UNINITIALIZED)
2278             && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2279         {
2280             report_uninit();
2281         }
2282         *lp = 0;
2283         if (SvTYPE(sv) < SVt_PV)
2284             /* Typically the caller expects that sv_any is not NULL now.  */
2285             sv_upgrade(sv, SVt_PV);
2286         return "";
2287     }
2288     *lp = s - SvPVX(sv);
2289     SvCUR_set(sv, *lp);
2290     SvPOK_on(sv);
2291     DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2292                           PTR2UV(sv),SvPVX(sv)));
2293     return SvPVX(sv);
2294
2295   tokensave:
2296     if (SvROK(sv)) {    /* XXX Skip this when sv_pvn_force calls */
2297         /* Sneaky stuff here */
2298
2299       tokensaveref:
2300         if (!tsv)
2301             tsv = newSVpv(tmpbuf, 0);
2302         sv_2mortal(tsv);
2303         *lp = SvCUR(tsv);
2304         return SvPVX(tsv);
2305     }
2306     else {
2307         STRLEN len;
2308         char *t;
2309
2310         if (tsv) {
2311             sv_2mortal(tsv);
2312             t = SvPVX(tsv);
2313             len = SvCUR(tsv);
2314         }
2315         else {
2316             t = tmpbuf;
2317             len = strlen(tmpbuf);
2318         }
2319 #ifdef FIXNEGATIVEZERO
2320         if (len == 2 && t[0] == '-' && t[1] == '0') {
2321             t = "0";
2322             len = 1;
2323         }
2324 #endif
2325         (void)SvUPGRADE(sv, SVt_PV);
2326         *lp = len;
2327         s = SvGROW(sv, len + 1);
2328         SvCUR_set(sv, len);
2329         (void)strcpy(s, t);
2330         SvPOKp_on(sv);
2331         return s;
2332     }
2333 }
2334
2335 char *
2336 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2337 {
2338     STRLEN n_a;
2339     return sv_2pvbyte(sv, &n_a);
2340 }
2341
2342 char *
2343 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2344 {
2345     return sv_2pv(sv,lp);
2346 }
2347
2348 char *
2349 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2350 {
2351     STRLEN n_a;
2352     return sv_2pvutf8(sv, &n_a);
2353 }
2354
2355 char *
2356 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2357 {
2358     sv_utf8_upgrade(sv);
2359     return sv_2pv(sv,lp);
2360 }
2361
2362 /* This function is only called on magical items */
2363 bool
2364 Perl_sv_2bool(pTHX_ register SV *sv)
2365 {
2366     if (SvGMAGICAL(sv))
2367         mg_get(sv);
2368
2369     if (!SvOK(sv))
2370         return 0;
2371     if (SvROK(sv)) {
2372         dTHR;
2373         SV* tmpsv;
2374         if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2375                 (SvRV(tmpsv) != SvRV(sv)))
2376             return SvTRUE(tmpsv);
2377       return SvRV(sv) != 0;
2378     }
2379     if (SvPOKp(sv)) {
2380         register XPV* Xpvtmp;
2381         if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2382                 (*Xpvtmp->xpv_pv > '0' ||
2383                 Xpvtmp->xpv_cur > 1 ||
2384                 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2385             return 1;
2386         else
2387             return 0;
2388     }
2389     else {
2390         if (SvIOKp(sv))
2391             return SvIVX(sv) != 0;
2392         else {
2393             if (SvNOKp(sv))
2394                 return SvNVX(sv) != 0.0;
2395             else
2396                 return FALSE;
2397         }
2398     }
2399 }
2400
2401 /*
2402 =for apidoc sv_utf8_upgrade
2403
2404 Convert the PV of an SV to its UTF8-encoded form.
2405
2406 =cut
2407 */
2408
2409 void
2410 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2411 {
2412     char *s, *t;
2413     bool hibit;
2414
2415     if (!sv || !SvPOK(sv) || SvUTF8(sv))
2416         return;
2417
2418     /* This function could be much more efficient if we had a FLAG in SVs
2419      * to signal if there are any hibit chars in the PV.
2420      */
2421     for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++)
2422         if (*t & 0x80)
2423             hibit = TRUE;
2424
2425     if (hibit) {
2426         STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
2427         SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2428         SvCUR(sv) = len - 1;
2429         SvLEN(sv) = len; /* No longer know the real size. */
2430         SvUTF8_on(sv);
2431         Safefree(s); /* No longer using what was there before. */
2432     }
2433 }
2434
2435 /*
2436 =for apidoc sv_utf8_downgrade
2437
2438 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2439 This may not be possible if the PV contains non-byte encoding characters;
2440 if this is the case, either returns false or, if C<fail_ok> is not
2441 true, croaks.
2442
2443 =cut
2444 */
2445
2446 bool
2447 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2448 {
2449     if (SvPOK(sv) && SvUTF8(sv)) {
2450         char *c = SvPVX(sv);
2451         STRLEN len = SvCUR(sv) + 1;     /* include trailing NUL */
2452         if (!utf8_to_bytes((U8*)c, &len)) {
2453             if (fail_ok)
2454                 return FALSE;
2455             else {
2456                 if (PL_op)
2457                     Perl_croak(aTHX_ "Wide character in %s",
2458                                PL_op_desc[PL_op->op_type]);
2459                 else
2460                     Perl_croak(aTHX_ "Wide character");
2461             }
2462         }
2463         SvCUR(sv) = len - 1;
2464         SvUTF8_off(sv);
2465     }
2466     return TRUE;
2467 }
2468
2469 /*
2470 =for apidoc sv_utf8_encode
2471
2472 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2473 flag so that it looks like bytes again. Nothing calls this.
2474
2475 =cut
2476 */
2477
2478 void
2479 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2480 {
2481     sv_utf8_upgrade(sv);
2482     SvUTF8_off(sv);
2483 }
2484
2485 bool
2486 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2487 {
2488     if (SvPOK(sv)) {
2489         char *c;
2490         bool has_utf = FALSE;
2491         if (!sv_utf8_downgrade(sv, TRUE))
2492             return FALSE;
2493
2494         /* it is actually just a matter of turning the utf8 flag on, but
2495          * we want to make sure everything inside is valid utf8 first.
2496          */
2497         c = SvPVX(sv);
2498         if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
2499             return FALSE;
2500
2501         while (c < SvEND(sv)) {
2502             if (*c++ & 0x80) {
2503                 SvUTF8_on(sv);
2504                 break;
2505             }
2506         }
2507     }
2508     return TRUE;
2509 }
2510
2511
2512 /* Note: sv_setsv() should not be called with a source string that needs
2513  * to be reused, since it may destroy the source string if it is marked
2514  * as temporary.
2515  */
2516
2517 /*
2518 =for apidoc sv_setsv
2519
2520 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2521 The source SV may be destroyed if it is mortal.  Does not handle 'set'
2522 magic.  See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2523 C<sv_setsv_mg>.
2524
2525 =cut
2526 */
2527
2528 void
2529 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2530 {
2531     dTHR;
2532     register U32 sflags;
2533     register int dtype;
2534     register int stype;
2535
2536     if (sstr == dstr)
2537         return;
2538     SV_CHECK_THINKFIRST(dstr);
2539     if (!sstr)
2540         sstr = &PL_sv_undef;
2541     stype = SvTYPE(sstr);
2542     dtype = SvTYPE(dstr);
2543
2544     SvAMAGIC_off(dstr);
2545
2546     /* There's a lot of redundancy below but we're going for speed here */
2547
2548     switch (stype) {
2549     case SVt_NULL:
2550       undef_sstr:
2551         if (dtype != SVt_PVGV) {
2552             (void)SvOK_off(dstr);
2553             return;
2554         }
2555         break;
2556     case SVt_IV:
2557         if (SvIOK(sstr)) {
2558             switch (dtype) {
2559             case SVt_NULL:
2560                 sv_upgrade(dstr, SVt_IV);
2561                 break;
2562             case SVt_NV:
2563                 sv_upgrade(dstr, SVt_PVNV);
2564                 break;
2565             case SVt_RV:
2566             case SVt_PV:
2567                 sv_upgrade(dstr, SVt_PVIV);
2568                 break;
2569             }
2570             (void)SvIOK_only(dstr);
2571             SvIVX(dstr) = SvIVX(sstr);
2572             if (SvIsUV(sstr))
2573                 SvIsUV_on(dstr);
2574             if (SvTAINTED(sstr))
2575                 SvTAINT(dstr);
2576             return;
2577         }
2578         goto undef_sstr;
2579
2580     case SVt_NV:
2581         if (SvNOK(sstr)) {
2582             switch (dtype) {
2583             case SVt_NULL:
2584             case SVt_IV:
2585                 sv_upgrade(dstr, SVt_NV);
2586                 break;
2587             case SVt_RV:
2588             case SVt_PV:
2589             case SVt_PVIV:
2590                 sv_upgrade(dstr, SVt_PVNV);
2591                 break;
2592             }
2593             SvNVX(dstr) = SvNVX(sstr);
2594             (void)SvNOK_only(dstr);
2595             if (SvTAINTED(sstr))
2596                 SvTAINT(dstr);
2597             return;
2598         }
2599         goto undef_sstr;
2600
2601     case SVt_RV:
2602         if (dtype < SVt_RV)
2603             sv_upgrade(dstr, SVt_RV);
2604         else if (dtype == SVt_PVGV &&
2605                  SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2606             sstr = SvRV(sstr);
2607             if (sstr == dstr) {
2608                 if (GvIMPORTED(dstr) != GVf_IMPORTED
2609                     && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2610                 {
2611                     GvIMPORTED_on(dstr);
2612                 }
2613                 GvMULTI_on(dstr);
2614                 return;
2615             }
2616             goto glob_assign;
2617         }
2618         break;
2619     case SVt_PV:
2620     case SVt_PVFM:
2621         if (dtype < SVt_PV)
2622             sv_upgrade(dstr, SVt_PV);
2623         break;
2624     case SVt_PVIV:
2625         if (dtype < SVt_PVIV)
2626             sv_upgrade(dstr, SVt_PVIV);
2627         break;
2628     case SVt_PVNV:
2629         if (dtype < SVt_PVNV)
2630             sv_upgrade(dstr, SVt_PVNV);
2631         break;
2632     case SVt_PVAV:
2633     case SVt_PVHV:
2634     case SVt_PVCV:
2635     case SVt_PVIO:
2636         if (PL_op)
2637             Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2638                 PL_op_name[PL_op->op_type]);
2639         else
2640             Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2641         break;
2642
2643     case SVt_PVGV:
2644         if (dtype <= SVt_PVGV) {
2645   glob_assign:
2646             if (dtype != SVt_PVGV) {
2647                 char *name = GvNAME(sstr);
2648                 STRLEN len = GvNAMELEN(sstr);
2649                 sv_upgrade(dstr, SVt_PVGV);
2650                 sv_magic(dstr, dstr, '*', Nullch, 0);
2651                 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2652                 GvNAME(dstr) = savepvn(name, len);
2653                 GvNAMELEN(dstr) = len;
2654                 SvFAKE_on(dstr);        /* can coerce to non-glob */
2655             }
2656             /* ahem, death to those who redefine active sort subs */
2657             else if (PL_curstackinfo->si_type == PERLSI_SORT
2658                      && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2659                 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2660                       GvNAME(dstr));
2661             (void)SvOK_off(dstr);
2662             GvINTRO_off(dstr);          /* one-shot flag */
2663             gp_free((GV*)dstr);
2664             GvGP(dstr) = gp_ref(GvGP(sstr));
2665             if (SvTAINTED(sstr))
2666                 SvTAINT(dstr);
2667             if (GvIMPORTED(dstr) != GVf_IMPORTED
2668                 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2669             {
2670                 GvIMPORTED_on(dstr);
2671             }
2672             GvMULTI_on(dstr);
2673             return;
2674         }
2675         /* FALL THROUGH */
2676
2677     default:
2678         if (SvGMAGICAL(sstr)) {
2679             mg_get(sstr);
2680             if (SvTYPE(sstr) != stype) {
2681                 stype = SvTYPE(sstr);
2682                 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2683                     goto glob_assign;
2684             }
2685         }
2686         if (stype == SVt_PVLV)
2687             (void)SvUPGRADE(dstr, SVt_PVNV);
2688         else
2689             (void)SvUPGRADE(dstr, stype);
2690     }
2691
2692     sflags = SvFLAGS(sstr);
2693
2694     if (sflags & SVf_ROK) {
2695         if (dtype >= SVt_PV) {
2696             if (dtype == SVt_PVGV) {
2697                 SV *sref = SvREFCNT_inc(SvRV(sstr));
2698                 SV *dref = 0;
2699                 int intro = GvINTRO(dstr);
2700
2701                 if (intro) {
2702                     GP *gp;
2703                     gp_free((GV*)dstr);
2704                     GvINTRO_off(dstr);  /* one-shot flag */
2705                     Newz(602,gp, 1, GP);
2706                     GvGP(dstr) = gp_ref(gp);
2707                     GvSV(dstr) = NEWSV(72,0);
2708                     GvLINE(dstr) = CopLINE(PL_curcop);
2709                     GvEGV(dstr) = (GV*)dstr;
2710                 }
2711                 GvMULTI_on(dstr);
2712                 switch (SvTYPE(sref)) {
2713                 case SVt_PVAV:
2714                     if (intro)
2715                         SAVESPTR(GvAV(dstr));
2716                     else
2717                         dref = (SV*)GvAV(dstr);
2718                     GvAV(dstr) = (AV*)sref;
2719                     if (!GvIMPORTED_AV(dstr)
2720                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2721                     {
2722                         GvIMPORTED_AV_on(dstr);
2723                     }
2724                     break;
2725                 case SVt_PVHV:
2726                     if (intro)
2727                         SAVESPTR(GvHV(dstr));
2728                     else
2729                         dref = (SV*)GvHV(dstr);
2730                     GvHV(dstr) = (HV*)sref;
2731                     if (!GvIMPORTED_HV(dstr)
2732                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2733                     {
2734                         GvIMPORTED_HV_on(dstr);
2735                     }
2736                     break;
2737                 case SVt_PVCV:
2738                     if (intro) {
2739                         if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2740                             SvREFCNT_dec(GvCV(dstr));
2741                             GvCV(dstr) = Nullcv;
2742                             GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2743                             PL_sub_generation++;
2744                         }
2745                         SAVESPTR(GvCV(dstr));
2746                     }
2747                     else
2748                         dref = (SV*)GvCV(dstr);
2749                     if (GvCV(dstr) != (CV*)sref) {
2750                         CV* cv = GvCV(dstr);
2751                         if (cv) {
2752                             if (!GvCVGEN((GV*)dstr) &&
2753                                 (CvROOT(cv) || CvXSUB(cv)))
2754                             {
2755                                 SV *const_sv;
2756                                 /* ahem, death to those who redefine
2757                                  * active sort subs */
2758                                 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2759                                       PL_sortcop == CvSTART(cv))
2760                                     Perl_croak(aTHX_
2761                                     "Can't redefine active sort subroutine %s",
2762                                           GvENAME((GV*)dstr));
2763                                 /* Redefining a sub - warning is mandatory if
2764                                    it was a const and its value changed. */
2765                                 if (ckWARN(WARN_REDEFINE)
2766                                     || (CvCONST(cv)
2767                                         && (!CvCONST((CV*)sref)
2768                                             || sv_cmp(cv_const_sv(cv),
2769                                                       cv_const_sv((CV*)sref)))))
2770                                 {
2771                                     Perl_warner(aTHX_ WARN_REDEFINE,
2772                                         CvCONST(cv)
2773                                         ? "Constant subroutine %s redefined"
2774                                         : "Subroutine %s redefined",
2775                                         GvENAME((GV*)dstr));
2776                                 }
2777                             }
2778                             cv_ckproto(cv, (GV*)dstr,
2779                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
2780                         }
2781                         GvCV(dstr) = (CV*)sref;
2782                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2783                         GvASSUMECV_on(dstr);
2784                         PL_sub_generation++;
2785                     }
2786                     if (!GvIMPORTED_CV(dstr)
2787                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2788                     {
2789                         GvIMPORTED_CV_on(dstr);
2790                     }
2791                     break;
2792                 case SVt_PVIO:
2793                     if (intro)
2794                         SAVESPTR(GvIOp(dstr));
2795                     else
2796                         dref = (SV*)GvIOp(dstr);
2797                     GvIOp(dstr) = (IO*)sref;
2798                     break;
2799                 case SVt_PVFM:
2800                     if (intro)
2801                         SAVESPTR(GvFORM(dstr));
2802                     else
2803                         dref = (SV*)GvFORM(dstr);
2804                     GvFORM(dstr) = (CV*)sref;
2805                     break;
2806                 default:
2807                     if (intro)
2808                         SAVESPTR(GvSV(dstr));
2809                     else
2810                         dref = (SV*)GvSV(dstr);
2811                     GvSV(dstr) = sref;
2812                     if (!GvIMPORTED_SV(dstr)
2813                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2814                     {
2815                         GvIMPORTED_SV_on(dstr);
2816                     }
2817                     break;
2818                 }
2819                 if (dref)
2820                     SvREFCNT_dec(dref);
2821                 if (intro)
2822                     SAVEFREESV(sref);
2823                 if (SvTAINTED(sstr))
2824                     SvTAINT(dstr);
2825                 return;
2826             }
2827             if (SvPVX(dstr)) {
2828                 (void)SvOOK_off(dstr);          /* backoff */
2829                 if (SvLEN(dstr))
2830                     Safefree(SvPVX(dstr));
2831                 SvLEN(dstr)=SvCUR(dstr)=0;
2832             }
2833         }
2834         (void)SvOK_off(dstr);
2835         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2836         SvROK_on(dstr);
2837         if (sflags & SVp_NOK) {
2838             SvNOK_on(dstr);
2839             SvNVX(dstr) = SvNVX(sstr);
2840         }
2841         if (sflags & SVp_IOK) {
2842             (void)SvIOK_on(dstr);
2843             SvIVX(dstr) = SvIVX(sstr);
2844             if (sflags & SVf_IVisUV)
2845                 SvIsUV_on(dstr);
2846         }
2847         if (SvAMAGIC(sstr)) {
2848             SvAMAGIC_on(dstr);
2849         }
2850     }
2851     else if (sflags & SVp_POK) {
2852
2853         /*
2854          * Check to see if we can just swipe the string.  If so, it's a
2855          * possible small lose on short strings, but a big win on long ones.
2856          * It might even be a win on short strings if SvPVX(dstr)
2857          * has to be allocated and SvPVX(sstr) has to be freed.
2858          */
2859
2860         if (SvTEMP(sstr) &&             /* slated for free anyway? */
2861             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
2862             !(sflags & SVf_OOK) &&      /* and not involved in OOK hack? */
2863             SvLEN(sstr)         &&      /* and really is a string */
2864             !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
2865         {
2866             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
2867                 if (SvOOK(dstr)) {
2868                     SvFLAGS(dstr) &= ~SVf_OOK;
2869                     Safefree(SvPVX(dstr) - SvIVX(dstr));
2870                 }
2871                 else if (SvLEN(dstr))
2872                     Safefree(SvPVX(dstr));
2873             }
2874             (void)SvPOK_only(dstr);
2875             SvPV_set(dstr, SvPVX(sstr));
2876             SvLEN_set(dstr, SvLEN(sstr));
2877             SvCUR_set(dstr, SvCUR(sstr));
2878
2879             SvTEMP_off(dstr);
2880             (void)SvOK_off(sstr);               /* NOTE: nukes most SvFLAGS on sstr */
2881             SvPV_set(sstr, Nullch);
2882             SvLEN_set(sstr, 0);
2883             SvCUR_set(sstr, 0);
2884             SvTEMP_off(sstr);
2885         }
2886         else {                                  /* have to copy actual string */
2887             STRLEN len = SvCUR(sstr);
2888
2889             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
2890             Move(SvPVX(sstr),SvPVX(dstr),len,char);
2891             SvCUR_set(dstr, len);
2892             *SvEND(dstr) = '\0';
2893             (void)SvPOK_only(dstr);
2894         }
2895         if ((sflags & SVf_UTF8) && !IN_BYTE)
2896             SvUTF8_on(dstr);
2897         /*SUPPRESS 560*/
2898         if (sflags & SVp_NOK) {
2899             SvNOK_on(dstr);
2900             SvNVX(dstr) = SvNVX(sstr);
2901         }
2902         if (sflags & SVp_IOK) {
2903             (void)SvIOK_on(dstr);
2904             SvIVX(dstr) = SvIVX(sstr);
2905             if (sflags & SVf_IVisUV)
2906                 SvIsUV_on(dstr);
2907         }
2908     }
2909     else if (sflags & SVp_NOK) {
2910         SvNVX(dstr) = SvNVX(sstr);
2911         (void)SvNOK_only(dstr);
2912         if (sflags & SVf_IOK) {
2913             (void)SvIOK_on(dstr);
2914             SvIVX(dstr) = SvIVX(sstr);
2915             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
2916             if (sflags & SVf_IVisUV)
2917                 SvIsUV_on(dstr);
2918         }
2919     }
2920     else if (sflags & SVp_IOK) {
2921         (void)SvIOK_only(dstr);
2922         SvIVX(dstr) = SvIVX(sstr);
2923         if (sflags & SVf_IVisUV)
2924             SvIsUV_on(dstr);
2925     }
2926     else {
2927         if (dtype == SVt_PVGV) {
2928             if (ckWARN(WARN_MISC))
2929                 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2930         }
2931         else
2932             (void)SvOK_off(dstr);
2933     }
2934     if (SvTAINTED(sstr))
2935         SvTAINT(dstr);
2936 }
2937
2938 /*
2939 =for apidoc sv_setsv_mg
2940
2941 Like C<sv_setsv>, but also handles 'set' magic.
2942
2943 =cut
2944 */
2945
2946 void
2947 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2948 {
2949     sv_setsv(dstr,sstr);
2950     SvSETMAGIC(dstr);
2951 }
2952
2953 /*
2954 =for apidoc sv_setpvn
2955
2956 Copies a string into an SV.  The C<len> parameter indicates the number of
2957 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
2958
2959 =cut
2960 */
2961
2962 void
2963 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2964 {
2965     register char *dptr;
2966     {
2967         /* len is STRLEN which is unsigned, need to copy to signed */
2968         IV iv = len;
2969         assert(iv >= 0);
2970     }
2971     SV_CHECK_THINKFIRST(sv);
2972     if (!ptr) {
2973         (void)SvOK_off(sv);
2974         return;
2975     }
2976     (void)SvUPGRADE(sv, SVt_PV);
2977
2978     SvGROW(sv, len + 1);
2979     dptr = SvPVX(sv);
2980     Move(ptr,dptr,len,char);
2981     dptr[len] = '\0';
2982     SvCUR_set(sv, len);
2983     (void)SvPOK_only(sv);               /* validate pointer */
2984     SvTAINT(sv);
2985 }
2986
2987 /*
2988 =for apidoc sv_setpvn_mg
2989
2990 Like C<sv_setpvn>, but also handles 'set' magic.
2991
2992 =cut
2993 */
2994
2995 void
2996 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2997 {
2998     sv_setpvn(sv,ptr,len);
2999     SvSETMAGIC(sv);
3000 }
3001
3002 /*
3003 =for apidoc sv_setpv
3004
3005 Copies a string into an SV.  The string must be null-terminated.  Does not
3006 handle 'set' magic.  See C<sv_setpv_mg>.
3007
3008 =cut
3009 */
3010
3011 void
3012 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3013 {
3014     register STRLEN len;
3015
3016     SV_CHECK_THINKFIRST(sv);
3017     if (!ptr) {
3018         (void)SvOK_off(sv);
3019         return;
3020     }
3021     len = strlen(ptr);
3022     (void)SvUPGRADE(sv, SVt_PV);
3023
3024     SvGROW(sv, len + 1);
3025     Move(ptr,SvPVX(sv),len+1,char);
3026     SvCUR_set(sv, len);
3027     (void)SvPOK_only(sv);               /* validate pointer */
3028     SvTAINT(sv);
3029 }
3030
3031 /*
3032 =for apidoc sv_setpv_mg
3033
3034 Like C<sv_setpv>, but also handles 'set' magic.
3035
3036 =cut
3037 */
3038
3039 void
3040 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3041 {
3042     sv_setpv(sv,ptr);
3043     SvSETMAGIC(sv);
3044 }
3045
3046 /*
3047 =for apidoc sv_usepvn
3048
3049 Tells an SV to use C<ptr> to find its string value.  Normally the string is
3050 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3051 The C<ptr> should point to memory that was allocated by C<malloc>.  The
3052 string length, C<len>, must be supplied.  This function will realloc the
3053 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3054 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
3055 See C<sv_usepvn_mg>.
3056
3057 =cut
3058 */
3059
3060 void
3061 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3062 {
3063     SV_CHECK_THINKFIRST(sv);
3064     (void)SvUPGRADE(sv, SVt_PV);
3065     if (!ptr) {
3066         (void)SvOK_off(sv);
3067         return;
3068     }
3069     (void)SvOOK_off(sv);
3070     if (SvPVX(sv) && SvLEN(sv))
3071         Safefree(SvPVX(sv));
3072     Renew(ptr, len+1, char);
3073     SvPVX(sv) = ptr;
3074     SvCUR_set(sv, len);
3075     SvLEN_set(sv, len+1);
3076     *SvEND(sv) = '\0';
3077     (void)SvPOK_only(sv);               /* validate pointer */
3078     SvTAINT(sv);
3079 }
3080
3081 /*
3082 =for apidoc sv_usepvn_mg
3083
3084 Like C<sv_usepvn>, but also handles 'set' magic.
3085
3086 =cut
3087 */
3088
3089 void
3090 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3091 {
3092     sv_usepvn(sv,ptr,len);
3093     SvSETMAGIC(sv);
3094 }
3095
3096 void
3097 Perl_sv_force_normal(pTHX_ register SV *sv)
3098 {
3099     if (SvREADONLY(sv)) {
3100         dTHR;
3101         if (SvFAKE(sv)) {
3102             char *pvx = SvPVX(sv);
3103             STRLEN len = SvCUR(sv);
3104             U32 hash   = SvUVX(sv);
3105             SvGROW(sv, len + 1);
3106             Move(pvx,SvPVX(sv),len,char);
3107             *SvEND(sv) = '\0';
3108             SvFAKE_off(sv);
3109             SvREADONLY_off(sv);
3110             unsharepvn(pvx,len,hash);
3111         }
3112         else if (PL_curcop != &PL_compiling)
3113             Perl_croak(aTHX_ PL_no_modify);
3114     }
3115     if (SvROK(sv))
3116         sv_unref(sv);
3117     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3118         sv_unglob(sv);
3119 }
3120
3121 /*
3122 =for apidoc sv_chop
3123
3124 Efficient removal of characters from the beginning of the string buffer.
3125 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3126 the string buffer.  The C<ptr> becomes the first character of the adjusted
3127 string.
3128
3129 =cut
3130 */
3131
3132 void
3133 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3134
3135
3136 {
3137     register STRLEN delta;
3138
3139     if (!ptr || !SvPOKp(sv))
3140         return;
3141     SV_CHECK_THINKFIRST(sv);
3142     if (SvTYPE(sv) < SVt_PVIV)
3143         sv_upgrade(sv,SVt_PVIV);
3144
3145     if (!SvOOK(sv)) {
3146         if (!SvLEN(sv)) { /* make copy of shared string */
3147             char *pvx = SvPVX(sv);
3148             STRLEN len = SvCUR(sv);
3149             SvGROW(sv, len + 1);
3150             Move(pvx,SvPVX(sv),len,char);
3151             *SvEND(sv) = '\0';
3152         }
3153         SvIVX(sv) = 0;
3154         SvFLAGS(sv) |= SVf_OOK;
3155     }
3156     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3157     delta = ptr - SvPVX(sv);
3158     SvLEN(sv) -= delta;
3159     SvCUR(sv) -= delta;
3160     SvPVX(sv) += delta;
3161     SvIVX(sv) += delta;
3162 }
3163
3164 /*
3165 =for apidoc sv_catpvn
3166
3167 Concatenates the string onto the end of the string which is in the SV.  The
3168 C<len> indicates number of bytes to copy.  Handles 'get' magic, but not
3169 'set' magic.  See C<sv_catpvn_mg>.
3170
3171 =cut
3172 */
3173
3174 void
3175 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3176 {
3177     STRLEN tlen;
3178     char *junk;
3179
3180     junk = SvPV_force(sv, tlen);
3181     SvGROW(sv, tlen + len + 1);
3182     if (ptr == junk)
3183         ptr = SvPVX(sv);
3184     Move(ptr,SvPVX(sv)+tlen,len,char);
3185     SvCUR(sv) += len;
3186     *SvEND(sv) = '\0';
3187     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3188     SvTAINT(sv);
3189 }
3190
3191 /*
3192 =for apidoc sv_catpvn_mg
3193
3194 Like C<sv_catpvn>, but also handles 'set' magic.
3195
3196 =cut
3197 */
3198
3199 void
3200 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3201 {
3202     sv_catpvn(sv,ptr,len);
3203     SvSETMAGIC(sv);
3204 }
3205
3206 /*
3207 =for apidoc sv_catsv
3208
3209 Concatenates the string from SV C<ssv> onto the end of the string in SV
3210 C<dsv>.  Handles 'get' magic, but not 'set' magic.  See C<sv_catsv_mg>.
3211
3212 =cut
3213 */
3214
3215 void
3216 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3217 {
3218     char *s;
3219     STRLEN len;
3220     if (!sstr)
3221         return;
3222     if ((s = SvPV(sstr, len))) {
3223         if (DO_UTF8(sstr)) {
3224             sv_utf8_upgrade(dstr);
3225             sv_catpvn(dstr,s,len);
3226             SvUTF8_on(dstr);
3227         }
3228         else
3229             sv_catpvn(dstr,s,len);
3230     }
3231 }
3232
3233 /*
3234 =for apidoc sv_catsv_mg
3235
3236 Like C<sv_catsv>, but also handles 'set' magic.
3237
3238 =cut
3239 */
3240
3241 void
3242 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3243 {
3244     sv_catsv(dstr,sstr);
3245     SvSETMAGIC(dstr);
3246 }
3247
3248 /*
3249 =for apidoc sv_catpv
3250
3251 Concatenates the string onto the end of the string which is in the SV.
3252 Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
3253
3254 =cut
3255 */
3256
3257 void
3258 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3259 {
3260     register STRLEN len;
3261     STRLEN tlen;
3262     char *junk;
3263
3264     if (!ptr)
3265         return;
3266     junk = SvPV_force(sv, tlen);
3267     len = strlen(ptr);
3268     SvGROW(sv, tlen + len + 1);
3269     if (ptr == junk)
3270         ptr = SvPVX(sv);
3271     Move(ptr,SvPVX(sv)+tlen,len+1,char);
3272     SvCUR(sv) += len;
3273     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3274     SvTAINT(sv);
3275 }
3276
3277 /*
3278 =for apidoc sv_catpv_mg
3279
3280 Like C<sv_catpv>, but also handles 'set' magic.
3281
3282 =cut
3283 */
3284
3285 void
3286 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3287 {
3288     sv_catpv(sv,ptr);
3289     SvSETMAGIC(sv);
3290 }
3291
3292 SV *
3293 Perl_newSV(pTHX_ STRLEN len)
3294 {
3295     register SV *sv;
3296
3297     new_SV(sv);
3298     if (len) {
3299         sv_upgrade(sv, SVt_PV);
3300         SvGROW(sv, len + 1);
3301     }
3302     return sv;
3303 }
3304
3305 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3306
3307 /*
3308 =for apidoc sv_magic
3309
3310 Adds magic to an SV.
3311
3312 =cut
3313 */
3314
3315 void
3316 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3317 {
3318     MAGIC* mg;
3319
3320     if (SvREADONLY(sv)) {
3321         dTHR;
3322         if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3323             Perl_croak(aTHX_ PL_no_modify);
3324     }
3325     if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3326         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3327             if (how == 't')
3328                 mg->mg_len |= 1;
3329             return;
3330         }
3331     }
3332     else {
3333         (void)SvUPGRADE(sv, SVt_PVMG);
3334     }
3335     Newz(702,mg, 1, MAGIC);
3336     mg->mg_moremagic = SvMAGIC(sv);
3337
3338     SvMAGIC(sv) = mg;
3339     if (!obj || obj == sv || how == '#' || how == 'r')
3340         mg->mg_obj = obj;
3341     else {
3342         dTHR;
3343         mg->mg_obj = SvREFCNT_inc(obj);
3344         mg->mg_flags |= MGf_REFCOUNTED;
3345     }
3346     mg->mg_type = how;
3347     mg->mg_len = namlen;
3348     if (name)
3349         if (namlen >= 0)
3350             mg->mg_ptr = savepvn(name, namlen);
3351         else if (namlen == HEf_SVKEY)
3352             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3353
3354     switch (how) {
3355     case 0:
3356         mg->mg_virtual = &PL_vtbl_sv;
3357         break;
3358     case 'A':
3359         mg->mg_virtual = &PL_vtbl_amagic;
3360         break;
3361     case 'a':
3362         mg->mg_virtual = &PL_vtbl_amagicelem;
3363         break;
3364     case 'c':
3365         mg->mg_virtual = 0;
3366         break;
3367     case 'B':
3368         mg->mg_virtual = &PL_vtbl_bm;
3369         break;
3370     case 'D':
3371         mg->mg_virtual = &PL_vtbl_regdata;
3372         break;
3373     case 'd':
3374         mg->mg_virtual = &PL_vtbl_regdatum;
3375         break;
3376     case 'E':
3377         mg->mg_virtual = &PL_vtbl_env;
3378         break;
3379     case 'f':
3380         mg->mg_virtual = &PL_vtbl_fm;
3381         break;
3382     case 'e':
3383         mg->mg_virtual = &PL_vtbl_envelem;
3384         break;
3385     case 'g':
3386         mg->mg_virtual = &PL_vtbl_mglob;
3387         break;
3388     case 'I':
3389         mg->mg_virtual = &PL_vtbl_isa;
3390         break;
3391     case 'i':
3392         mg->mg_virtual = &PL_vtbl_isaelem;
3393         break;
3394     case 'k':
3395         mg->mg_virtual = &PL_vtbl_nkeys;
3396         break;
3397     case 'L':
3398         SvRMAGICAL_on(sv);
3399         mg->mg_virtual = 0;
3400         break;
3401     case 'l':
3402         mg->mg_virtual = &PL_vtbl_dbline;
3403         break;
3404 #ifdef USE_THREADS
3405     case 'm':
3406         mg->mg_virtual = &PL_vtbl_mutex;
3407         break;
3408 #endif /* USE_THREADS */
3409 #ifdef USE_LOCALE_COLLATE
3410     case 'o':
3411         mg->mg_virtual = &PL_vtbl_collxfrm;
3412         break;
3413 #endif /* USE_LOCALE_COLLATE */
3414     case 'P':
3415         mg->mg_virtual = &PL_vtbl_pack;
3416         break;
3417     case 'p':
3418     case 'q':
3419         mg->mg_virtual = &PL_vtbl_packelem;
3420         break;
3421     case 'r':
3422         mg->mg_virtual = &PL_vtbl_regexp;
3423         break;
3424     case 'S':
3425         mg->mg_virtual = &PL_vtbl_sig;
3426         break;
3427     case 's':
3428         mg->mg_virtual = &PL_vtbl_sigelem;
3429         break;
3430     case 't':
3431         mg->mg_virtual = &PL_vtbl_taint;
3432         mg->mg_len = 1;
3433         break;
3434     case 'U':
3435         mg->mg_virtual = &PL_vtbl_uvar;
3436         break;
3437     case 'v':
3438         mg->mg_virtual = &PL_vtbl_vec;
3439         break;
3440     case 'x':
3441         mg->mg_virtual = &PL_vtbl_substr;
3442         break;
3443     case 'y':
3444         mg->mg_virtual = &PL_vtbl_defelem;
3445         break;
3446     case '*':
3447         mg->mg_virtual = &PL_vtbl_glob;
3448         break;
3449     case '#':
3450         mg->mg_virtual = &PL_vtbl_arylen;
3451         break;
3452     case '.':
3453         mg->mg_virtual = &PL_vtbl_pos;
3454         break;
3455     case '<':
3456         mg->mg_virtual = &PL_vtbl_backref;
3457         break;
3458     case '~':   /* Reserved for use by extensions not perl internals.   */
3459         /* Useful for attaching extension internal data to perl vars.   */
3460         /* Note that multiple extensions may clash if magical scalars   */
3461         /* etc holding private data from one are passed to another.     */
3462         SvRMAGICAL_on(sv);
3463         break;
3464     default:
3465         Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3466     }
3467     mg_magical(sv);
3468     if (SvGMAGICAL(sv))
3469         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3470 }
3471
3472 /*
3473 =for apidoc sv_unmagic
3474
3475 Removes magic from an SV.
3476
3477 =cut
3478 */
3479
3480 int
3481 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3482 {
3483     MAGIC* mg;
3484     MAGIC** mgp;
3485     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3486         return 0;
3487     mgp = &SvMAGIC(sv);
3488     for (mg = *mgp; mg; mg = *mgp) {
3489         if (mg->mg_type == type) {
3490             MGVTBL* vtbl = mg->mg_virtual;
3491             *mgp = mg->mg_moremagic;
3492             if (vtbl && vtbl->svt_free)
3493                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3494             if (mg->mg_ptr && mg->mg_type != 'g')
3495                 if (mg->mg_len >= 0)
3496                     Safefree(mg->mg_ptr);
3497                 else if (mg->mg_len == HEf_SVKEY)
3498                     SvREFCNT_dec((SV*)mg->mg_ptr);
3499             if (mg->mg_flags & MGf_REFCOUNTED)
3500                 SvREFCNT_dec(mg->mg_obj);
3501             Safefree(mg);
3502         }
3503         else
3504             mgp = &mg->mg_moremagic;
3505     }
3506     if (!SvMAGIC(sv)) {
3507         SvMAGICAL_off(sv);
3508         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3509     }
3510
3511     return 0;
3512 }
3513
3514 /*
3515 =for apidoc sv_rvweaken
3516
3517 Weaken a reference.
3518
3519 =cut
3520 */
3521
3522 SV *
3523 Perl_sv_rvweaken(pTHX_ SV *sv)
3524 {
3525     SV *tsv;
3526     if (!SvOK(sv))  /* let undefs pass */
3527         return sv;
3528     if (!SvROK(sv))
3529         Perl_croak(aTHX_ "Can't weaken a nonreference");
3530     else if (SvWEAKREF(sv)) {
3531         dTHR;
3532         if (ckWARN(WARN_MISC))
3533             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3534         return sv;
3535     }
3536     tsv = SvRV(sv);
3537     sv_add_backref(tsv, sv);
3538     SvWEAKREF_on(sv);
3539     SvREFCNT_dec(tsv);
3540     return sv;
3541 }
3542
3543 STATIC void
3544 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3545 {
3546     AV *av;
3547     MAGIC *mg;
3548     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3549         av = (AV*)mg->mg_obj;
3550     else {
3551         av = newAV();
3552         sv_magic(tsv, (SV*)av, '<', NULL, 0);
3553         SvREFCNT_dec(av);           /* for sv_magic */
3554     }
3555     av_push(av,sv);
3556 }
3557
3558 STATIC void
3559 S_sv_del_backref(pTHX_ SV *sv)
3560 {
3561     AV *av;
3562     SV **svp;
3563     I32 i;
3564     SV *tsv = SvRV(sv);
3565     MAGIC *mg;
3566     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3567         Perl_croak(aTHX_ "panic: del_backref");
3568     av = (AV *)mg->mg_obj;
3569     svp = AvARRAY(av);
3570     i = AvFILLp(av);
3571     while (i >= 0) {
3572         if (svp[i] == sv) {
3573             svp[i] = &PL_sv_undef; /* XXX */
3574         }
3575         i--;
3576     }
3577 }
3578
3579 /*
3580 =for apidoc sv_insert
3581
3582 Inserts a string at the specified offset/length within the SV. Similar to
3583 the Perl substr() function.
3584
3585 =cut
3586 */
3587
3588 void
3589 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3590 {
3591     register char *big;
3592     register char *mid;
3593     register char *midend;
3594     register char *bigend;
3595     register I32 i;
3596     STRLEN curlen;
3597
3598
3599     if (!bigstr)
3600         Perl_croak(aTHX_ "Can't modify non-existent substring");
3601     SvPV_force(bigstr, curlen);
3602     (void)SvPOK_only_UTF8(bigstr);
3603     if (offset + len > curlen) {
3604         SvGROW(bigstr, offset+len+1);
3605         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3606         SvCUR_set(bigstr, offset+len);
3607     }
3608
3609     SvTAINT(bigstr);
3610     i = littlelen - len;
3611     if (i > 0) {                        /* string might grow */
3612         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3613         mid = big + offset + len;
3614         midend = bigend = big + SvCUR(bigstr);
3615         bigend += i;
3616         *bigend = '\0';
3617         while (midend > mid)            /* shove everything down */
3618             *--bigend = *--midend;
3619         Move(little,big+offset,littlelen,char);
3620         SvCUR(bigstr) += i;
3621         SvSETMAGIC(bigstr);
3622         return;
3623     }
3624     else if (i == 0) {
3625         Move(little,SvPVX(bigstr)+offset,len,char);
3626         SvSETMAGIC(bigstr);
3627         return;
3628     }
3629
3630     big = SvPVX(bigstr);
3631     mid = big + offset;
3632     midend = mid + len;
3633     bigend = big + SvCUR(bigstr);
3634
3635     if (midend > bigend)
3636         Perl_croak(aTHX_ "panic: sv_insert");
3637
3638     if (mid - big > bigend - midend) {  /* faster to shorten from end */
3639         if (littlelen) {
3640             Move(little, mid, littlelen,char);
3641             mid += littlelen;
3642         }
3643         i = bigend - midend;
3644         if (i > 0) {
3645             Move(midend, mid, i,char);
3646             mid += i;
3647         }
3648         *mid = '\0';
3649         SvCUR_set(bigstr, mid - big);
3650     }
3651     /*SUPPRESS 560*/
3652     else if ((i = mid - big)) { /* faster from front */
3653         midend -= littlelen;
3654         mid = midend;
3655         sv_chop(bigstr,midend-i);
3656         big += i;
3657         while (i--)
3658             *--midend = *--big;
3659         if (littlelen)
3660             Move(little, mid, littlelen,char);
3661     }
3662     else if (littlelen) {
3663         midend -= littlelen;
3664         sv_chop(bigstr,midend);
3665         Move(little,midend,littlelen,char);
3666     }
3667     else {
3668         sv_chop(bigstr,midend);
3669     }
3670     SvSETMAGIC(bigstr);
3671 }
3672
3673 /*
3674 =for apidoc sv_replace
3675
3676 Make the first argument a copy of the second, then delete the original.
3677
3678 =cut
3679 */
3680
3681 void
3682 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3683 {
3684     dTHR;
3685     U32 refcnt = SvREFCNT(sv);
3686     SV_CHECK_THINKFIRST(sv);
3687     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3688         Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3689     if (SvMAGICAL(sv)) {
3690         if (SvMAGICAL(nsv))
3691             mg_free(nsv);
3692         else
3693             sv_upgrade(nsv, SVt_PVMG);
3694         SvMAGIC(nsv) = SvMAGIC(sv);
3695         SvFLAGS(nsv) |= SvMAGICAL(sv);
3696         SvMAGICAL_off(sv);
3697         SvMAGIC(sv) = 0;
3698     }
3699     SvREFCNT(sv) = 0;
3700     sv_clear(sv);
3701     assert(!SvREFCNT(sv));
3702     StructCopy(nsv,sv,SV);
3703     SvREFCNT(sv) = refcnt;
3704     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
3705     del_SV(nsv);
3706 }
3707
3708 /*
3709 =for apidoc sv_clear
3710
3711 Clear an SV, making it empty. Does not free the memory used by the SV
3712 itself.
3713
3714 =cut
3715 */
3716
3717 void
3718 Perl_sv_clear(pTHX_ register SV *sv)
3719 {
3720     HV* stash;
3721     assert(sv);
3722     assert(SvREFCNT(sv) == 0);
3723
3724     if (SvOBJECT(sv)) {
3725         dTHR;
3726         if (PL_defstash) {              /* Still have a symbol table? */
3727             djSP;
3728             GV* destructor;
3729             SV tmpref;
3730
3731             Zero(&tmpref, 1, SV);
3732             sv_upgrade(&tmpref, SVt_RV);
3733             SvROK_on(&tmpref);
3734             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
3735             SvREFCNT(&tmpref) = 1;
3736
3737             do {
3738                 stash = SvSTASH(sv);
3739                 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3740                 if (destructor) {
3741                     ENTER;
3742                     PUSHSTACKi(PERLSI_DESTROY);
3743                     SvRV(&tmpref) = SvREFCNT_inc(sv);
3744                     EXTEND(SP, 2);
3745                     PUSHMARK(SP);
3746                     PUSHs(&tmpref);
3747                     PUTBACK;
3748                     call_sv((SV*)GvCV(destructor),
3749                             G_DISCARD|G_EVAL|G_KEEPERR);
3750                     SvREFCNT(sv)--;
3751                     POPSTACK;
3752                     SPAGAIN;
3753                     LEAVE;
3754                 }
3755             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3756
3757             del_XRV(SvANY(&tmpref));
3758
3759             if (SvREFCNT(sv)) {
3760                 if (PL_in_clean_objs)
3761                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3762                           HvNAME(stash));
3763                 /* DESTROY gave object new lease on life */
3764                 return;
3765             }
3766         }
3767
3768         if (SvOBJECT(sv)) {
3769             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
3770             SvOBJECT_off(sv);   /* Curse the object. */
3771             if (SvTYPE(sv) != SVt_PVIO)
3772                 --PL_sv_objcount;       /* XXX Might want something more general */
3773         }
3774     }
3775     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3776         mg_free(sv);
3777     stash = NULL;
3778     switch (SvTYPE(sv)) {
3779     case SVt_PVIO:
3780         if (IoIFP(sv) &&
3781             IoIFP(sv) != PerlIO_stdin() &&
3782             IoIFP(sv) != PerlIO_stdout() &&
3783             IoIFP(sv) != PerlIO_stderr())
3784         {
3785             io_close((IO*)sv, FALSE);
3786         }
3787         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3788             PerlDir_close(IoDIRP(sv));
3789         IoDIRP(sv) = (DIR*)NULL;
3790         Safefree(IoTOP_NAME(sv));
3791         Safefree(IoFMT_NAME(sv));
3792         Safefree(IoBOTTOM_NAME(sv));
3793         /* FALL THROUGH */
3794     case SVt_PVBM:
3795         goto freescalar;
3796     case SVt_PVCV:
3797     case SVt_PVFM:
3798         cv_undef((CV*)sv);
3799         goto freescalar;
3800     case SVt_PVHV:
3801         hv_undef((HV*)sv);
3802         break;
3803     case SVt_PVAV:
3804         av_undef((AV*)sv);
3805         break;
3806     case SVt_PVLV:
3807         SvREFCNT_dec(LvTARG(sv));
3808         goto freescalar;
3809     case SVt_PVGV:
3810         gp_free((GV*)sv);
3811         Safefree(GvNAME(sv));
3812         /* cannot decrease stash refcount yet, as we might recursively delete
3813            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3814            of stash until current sv is completely gone.
3815            -- JohnPC, 27 Mar 1998 */
3816         stash = GvSTASH(sv);
3817         /* FALL THROUGH */
3818     case SVt_PVMG:
3819     case SVt_PVNV:
3820     case SVt_PVIV:
3821       freescalar:
3822         (void)SvOOK_off(sv);
3823         /* FALL THROUGH */
3824     case SVt_PV:
3825     case SVt_RV:
3826         if (SvROK(sv)) {
3827             if (SvWEAKREF(sv))
3828                 sv_del_backref(sv);
3829             else
3830                 SvREFCNT_dec(SvRV(sv));
3831         }
3832         else if (SvPVX(sv) && SvLEN(sv))
3833             Safefree(SvPVX(sv));
3834         else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
3835             unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv));
3836             SvFAKE_off(sv);
3837         }
3838         break;
3839 /*
3840     case SVt_NV:
3841     case SVt_IV:
3842     case SVt_NULL:
3843         break;
3844 */
3845     }
3846
3847     switch (SvTYPE(sv)) {
3848     case SVt_NULL:
3849         break;
3850     case SVt_IV:
3851         del_XIV(SvANY(sv));
3852         break;
3853     case SVt_NV:
3854         del_XNV(SvANY(sv));
3855         break;
3856     case SVt_RV:
3857         del_XRV(SvANY(sv));
3858         break;
3859     case SVt_PV:
3860         del_XPV(SvANY(sv));
3861         break;
3862     case SVt_PVIV:
3863         del_XPVIV(SvANY(sv));
3864         break;
3865     case SVt_PVNV:
3866         del_XPVNV(SvANY(sv));
3867         break;
3868     case SVt_PVMG:
3869         del_XPVMG(SvANY(sv));
3870         break;
3871     case SVt_PVLV:
3872         del_XPVLV(SvANY(sv));
3873         break;
3874     case SVt_PVAV:
3875         del_XPVAV(SvANY(sv));
3876         break;
3877     case SVt_PVHV:
3878         del_XPVHV(SvANY(sv));
3879         break;
3880     case SVt_PVCV:
3881         del_XPVCV(SvANY(sv));
3882         break;
3883     case SVt_PVGV:
3884         del_XPVGV(SvANY(sv));
3885         /* code duplication for increased performance. */
3886         SvFLAGS(sv) &= SVf_BREAK;
3887         SvFLAGS(sv) |= SVTYPEMASK;
3888         /* decrease refcount of the stash that owns this GV, if any */
3889         if (stash)
3890             SvREFCNT_dec(stash);
3891         return; /* not break, SvFLAGS reset already happened */
3892     case SVt_PVBM:
3893         del_XPVBM(SvANY(sv));
3894         break;
3895     case SVt_PVFM:
3896         del_XPVFM(SvANY(sv));
3897         break;
3898     case SVt_PVIO:
3899         del_XPVIO(SvANY(sv));
3900         break;
3901     }
3902     SvFLAGS(sv) &= SVf_BREAK;
3903     SvFLAGS(sv) |= SVTYPEMASK;
3904 }
3905
3906 SV *
3907 Perl_sv_newref(pTHX_ SV *sv)
3908 {
3909     if (sv)
3910         ATOMIC_INC(SvREFCNT(sv));
3911     return sv;
3912 }
3913
3914 /*
3915 =for apidoc sv_free
3916
3917 Free the memory used by an SV.
3918
3919 =cut
3920 */
3921
3922 void
3923 Perl_sv_free(pTHX_ SV *sv)
3924 {
3925     dTHR;
3926     int refcount_is_zero;
3927
3928     if (!sv)
3929         return;
3930     if (SvREFCNT(sv) == 0) {
3931         if (SvFLAGS(sv) & SVf_BREAK)
3932             return;
3933         if (PL_in_clean_all) /* All is fair */
3934             return;
3935         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3936             /* make sure SvREFCNT(sv)==0 happens very seldom */
3937             SvREFCNT(sv) = (~(U32)0)/2;
3938             return;
3939         }
3940         if (ckWARN_d(WARN_INTERNAL))
3941             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3942         return;
3943     }
3944     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3945     if (!refcount_is_zero)
3946         return;
3947 #ifdef DEBUGGING
3948     if (SvTEMP(sv)) {
3949         if (ckWARN_d(WARN_DEBUGGING))
3950             Perl_warner(aTHX_ WARN_DEBUGGING,
3951                         "Attempt to free temp prematurely: SV 0x%"UVxf,
3952                         PTR2UV(sv));
3953         return;
3954     }
3955 #endif
3956     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3957         /* make sure SvREFCNT(sv)==0 happens very seldom */
3958         SvREFCNT(sv) = (~(U32)0)/2;
3959         return;
3960     }
3961     sv_clear(sv);
3962     if (! SvREFCNT(sv))
3963         del_SV(sv);
3964 }
3965
3966 /*
3967 =for apidoc sv_len
3968
3969 Returns the length of the string in the SV.  See also C<SvCUR>.
3970
3971 =cut
3972 */
3973
3974 STRLEN
3975 Perl_sv_len(pTHX_ register SV *sv)
3976 {
3977     char *junk;
3978     STRLEN len;
3979
3980     if (!sv)
3981         return 0;
3982
3983     if (SvGMAGICAL(sv))
3984         len = mg_length(sv);
3985     else
3986         junk = SvPV(sv, len);
3987     return len;
3988 }
3989
3990 /*
3991 =for apidoc sv_len_utf8
3992
3993 Returns the number of characters in the string in an SV, counting wide
3994 UTF8 bytes as a single character.
3995
3996 =cut
3997 */
3998
3999 STRLEN
4000 Perl_sv_len_utf8(pTHX_ register SV *sv)
4001 {
4002     if (!sv)
4003         return 0;
4004
4005 #ifdef NOTYET
4006     if (SvGMAGICAL(sv))
4007         return mg_length(sv);
4008     else
4009 #endif
4010     {
4011         STRLEN len;
4012         U8 *s = (U8*)SvPV(sv, len);
4013
4014         return Perl_utf8_length(aTHX_ s, s + len);
4015     }
4016 }
4017
4018 void
4019 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4020 {
4021     U8 *start;
4022     U8 *s;
4023     U8 *send;
4024     I32 uoffset = *offsetp;
4025     STRLEN len;
4026
4027     if (!sv)
4028         return;
4029
4030     start = s = (U8*)SvPV(sv, len);
4031     send = s + len;
4032     while (s < send && uoffset--)
4033         s += UTF8SKIP(s);
4034     if (s >= send)
4035         s = send;
4036     *offsetp = s - start;
4037     if (lenp) {
4038         I32 ulen = *lenp;
4039         start = s;
4040         while (s < send && ulen--)
4041             s += UTF8SKIP(s);
4042         if (s >= send)
4043             s = send;
4044         *lenp = s - start;
4045     }
4046     return;
4047 }
4048
4049 void
4050 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4051 {
4052     U8 *s;
4053     U8 *send;
4054     STRLEN len;
4055
4056     if (!sv)
4057         return;
4058
4059     s = (U8*)SvPV(sv, len);
4060     if (len < *offsetp)
4061         Perl_croak(aTHX_ "panic: bad byte offset");
4062     send = s + *offsetp;
4063     len = 0;
4064     while (s < send) {
4065         s += UTF8SKIP(s);
4066         ++len;
4067     }
4068     if (s != send) {
4069         dTHR;
4070         if (ckWARN_d(WARN_UTF8))
4071             Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4072         --len;
4073     }
4074     *offsetp = len;
4075     return;
4076 }
4077
4078 /*
4079 =for apidoc sv_eq
4080
4081 Returns a boolean indicating whether the strings in the two SVs are
4082 identical.
4083
4084 =cut
4085 */
4086
4087 I32
4088 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4089 {
4090     char *pv1;
4091     STRLEN cur1;
4092     char *pv2;
4093     STRLEN cur2;
4094     I32  eq     = 0;
4095     bool pv1tmp = FALSE;
4096     bool pv2tmp = FALSE;
4097
4098     if (!sv1) {
4099         pv1 = "";
4100         cur1 = 0;
4101     }
4102     else
4103         pv1 = SvPV(sv1, cur1);
4104
4105     if (!sv2){
4106         pv2 = "";
4107         cur2 = 0;
4108     }
4109     else
4110         pv2 = SvPV(sv2, cur2);
4111
4112     /* do not utf8ize the comparands as a side-effect */
4113     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4114         if (SvUTF8(sv1)) {
4115             pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4116             pv2tmp = TRUE;
4117         }
4118         else {
4119             pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4120             pv1tmp = TRUE;
4121         }
4122     }
4123
4124     if (cur1 == cur2)
4125         eq = memEQ(pv1, pv2, cur1);
4126
4127     if (pv1tmp)
4128         Safefree(pv1);
4129     if (pv2tmp)
4130         Safefree(pv2);
4131
4132     return eq;
4133 }
4134
4135 /*
4136 =for apidoc sv_cmp
4137
4138 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
4139 string in C<sv1> is less than, equal to, or greater than the string in
4140 C<sv2>.
4141
4142 =cut
4143 */
4144
4145 I32
4146 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4147 {
4148     STRLEN cur1, cur2;
4149     char *pv1, *pv2;
4150     I32  cmp;
4151     bool pv1tmp = FALSE;
4152     bool pv2tmp = FALSE;
4153
4154     if (!sv1) {
4155         pv1 = "";
4156         cur1 = 0;
4157     }
4158     else
4159         pv1 = SvPV(sv1, cur1);
4160
4161     if (!sv2){
4162         pv2 = "";
4163         cur2 = 0;
4164     }
4165     else
4166         pv2 = SvPV(sv2, cur2);
4167
4168     /* do not utf8ize the comparands as a side-effect */
4169     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4170         if (SvUTF8(sv1)) {
4171             pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4172             pv2tmp = TRUE;
4173         }
4174         else {
4175             pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4176             pv1tmp = TRUE;
4177         }
4178     }
4179
4180     if (!cur1) {
4181         cmp = cur2 ? -1 : 0;
4182     } else if (!cur2) {
4183         cmp = 1;
4184     } else {
4185         I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4186
4187         if (retval) {
4188             cmp = retval < 0 ? -1 : 1;
4189         } else if (cur1 == cur2) {
4190             cmp = 0;
4191         } else {
4192             cmp = cur1 < cur2 ? -1 : 1;
4193         }
4194     }
4195
4196     if (pv1tmp)
4197         Safefree(pv1);
4198     if (pv2tmp)
4199         Safefree(pv2);
4200
4201     return cmp;
4202 }
4203
4204 /*
4205 =for apidoc sv_cmp_locale
4206
4207 Compares the strings in two SVs in a locale-aware manner. See
4208 L</sv_cmp_locale>
4209
4210 =cut
4211 */
4212
4213 I32
4214 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4215 {
4216 #ifdef USE_LOCALE_COLLATE
4217
4218     char *pv1, *pv2;
4219     STRLEN len1, len2;
4220     I32 retval;
4221
4222     if (PL_collation_standard)
4223         goto raw_compare;
4224
4225     len1 = 0;
4226     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4227     len2 = 0;
4228     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4229
4230     if (!pv1 || !len1) {
4231         if (pv2 && len2)
4232             return -1;
4233         else
4234             goto raw_compare;
4235     }
4236     else {
4237         if (!pv2 || !len2)
4238             return 1;
4239     }
4240
4241     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4242
4243     if (retval)
4244         return retval < 0 ? -1 : 1;
4245
4246     /*
4247      * When the result of collation is equality, that doesn't mean
4248      * that there are no differences -- some locales exclude some
4249      * characters from consideration.  So to avoid false equalities,
4250      * we use the raw string as a tiebreaker.
4251      */
4252
4253   raw_compare:
4254     /* FALL THROUGH */
4255
4256 #endif /* USE_LOCALE_COLLATE */
4257
4258     return sv_cmp(sv1, sv2);
4259 }
4260
4261 #ifdef USE_LOCALE_COLLATE
4262 /*
4263  * Any scalar variable may carry an 'o' magic that contains the
4264  * scalar data of the variable transformed to such a format that
4265  * a normal memory comparison can be used to compare the data
4266  * according to the locale settings.
4267  */
4268 char *
4269 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4270 {
4271     MAGIC *mg;
4272
4273     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4274     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4275         char *s, *xf;
4276         STRLEN len, xlen;
4277
4278         if (mg)
4279             Safefree(mg->mg_ptr);
4280         s = SvPV(sv, len);
4281         if ((xf = mem_collxfrm(s, len, &xlen))) {
4282             if (SvREADONLY(sv)) {
4283                 SAVEFREEPV(xf);
4284                 *nxp = xlen;
4285                 return xf + sizeof(PL_collation_ix);
4286             }
4287             if (! mg) {
4288                 sv_magic(sv, 0, 'o', 0, 0);
4289                 mg = mg_find(sv, 'o');
4290                 assert(mg);
4291             }
4292             mg->mg_ptr = xf;
4293             mg->mg_len = xlen;
4294         }
4295         else {
4296             if (mg) {
4297                 mg->mg_ptr = NULL;
4298                 mg->mg_len = -1;
4299             }
4300         }
4301     }
4302     if (mg && mg->mg_ptr) {
4303         *nxp = mg->mg_len;
4304         return mg->mg_ptr + sizeof(PL_collation_ix);
4305     }
4306     else {
4307         *nxp = 0;
4308         return NULL;
4309     }
4310 }
4311
4312 #endif /* USE_LOCALE_COLLATE */
4313
4314 /*
4315 =for apidoc sv_gets
4316
4317 Get a line from the filehandle and store it into the SV, optionally
4318 appending to the currently-stored string.
4319
4320 =cut
4321 */
4322
4323 char *
4324 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4325 {
4326     dTHR;
4327     char *rsptr;
4328     STRLEN rslen;
4329     register STDCHAR rslast;
4330     register STDCHAR *bp;
4331     register I32 cnt;
4332     I32 i;
4333
4334     SV_CHECK_THINKFIRST(sv);
4335     (void)SvUPGRADE(sv, SVt_PV);
4336
4337     SvSCREAM_off(sv);
4338
4339     if (RsSNARF(PL_rs)) {
4340         rsptr = NULL;
4341         rslen = 0;
4342     }
4343     else if (RsRECORD(PL_rs)) {
4344       I32 recsize, bytesread;
4345       char *buffer;
4346
4347       /* Grab the size of the record we're getting */
4348       recsize = SvIV(SvRV(PL_rs));
4349       (void)SvPOK_only(sv);    /* Validate pointer */
4350       buffer = SvGROW(sv, recsize + 1);
4351       /* Go yank in */
4352 #ifdef VMS
4353       /* VMS wants read instead of fread, because fread doesn't respect */
4354       /* RMS record boundaries. This is not necessarily a good thing to be */
4355       /* doing, but we've got no other real choice */
4356       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4357 #else
4358       bytesread = PerlIO_read(fp, buffer, recsize);
4359 #endif
4360       SvCUR_set(sv, bytesread);
4361       buffer[bytesread] = '\0';
4362       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4363     }
4364     else if (RsPARA(PL_rs)) {
4365         rsptr = "\n\n";
4366         rslen = 2;
4367     }
4368     else
4369         rsptr = SvPV(PL_rs, rslen);
4370     rslast = rslen ? rsptr[rslen - 1] : '\0';
4371
4372     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
4373         do {                    /* to make sure file boundaries work right */
4374             if (PerlIO_eof(fp))
4375                 return 0;
4376             i = PerlIO_getc(fp);
4377             if (i != '\n') {
4378                 if (i == -1)
4379                     return 0;
4380                 PerlIO_ungetc(fp,i);
4381                 break;
4382             }
4383         } while (i != EOF);
4384     }
4385
4386     /* See if we know enough about I/O mechanism to cheat it ! */
4387
4388     /* This used to be #ifdef test - it is made run-time test for ease
4389        of abstracting out stdio interface. One call should be cheap
4390        enough here - and may even be a macro allowing compile
4391        time optimization.
4392      */
4393
4394     if (PerlIO_fast_gets(fp)) {
4395
4396     /*
4397      * We're going to steal some values from the stdio struct
4398      * and put EVERYTHING in the innermost loop into registers.
4399      */
4400     register STDCHAR *ptr;
4401     STRLEN bpx;
4402     I32 shortbuffered;
4403
4404 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4405     /* An ungetc()d char is handled separately from the regular
4406      * buffer, so we getc() it back out and stuff it in the buffer.
4407      */
4408     i = PerlIO_getc(fp);
4409     if (i == EOF) return 0;
4410     *(--((*fp)->_ptr)) = (unsigned char) i;
4411     (*fp)->_cnt++;
4412 #endif
4413
4414     /* Here is some breathtakingly efficient cheating */
4415
4416     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
4417     (void)SvPOK_only(sv);               /* validate pointer */
4418     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4419         if (cnt > 80 && SvLEN(sv) > append) {
4420             shortbuffered = cnt - SvLEN(sv) + append + 1;
4421             cnt -= shortbuffered;
4422         }
4423         else {
4424             shortbuffered = 0;
4425             /* remember that cnt can be negative */
4426             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4427         }
4428     }
4429     else
4430         shortbuffered = 0;
4431     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
4432     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4433     DEBUG_P(PerlIO_printf(Perl_debug_log,
4434         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4435     DEBUG_P(PerlIO_printf(Perl_debug_log,
4436         "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4437                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4438                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4439     for (;;) {
4440       screamer:
4441         if (cnt > 0) {
4442             if (rslen) {
4443                 while (cnt > 0) {                    /* this     |  eat */
4444                     cnt--;
4445                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
4446                         goto thats_all_folks;        /* screams  |  sed :-) */
4447                 }
4448             }
4449             else {
4450                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
4451                 bp += cnt;                           /* screams  |  dust */
4452                 ptr += cnt;                          /* louder   |  sed :-) */
4453                 cnt = 0;
4454             }
4455         }
4456
4457         if (shortbuffered) {            /* oh well, must extend */
4458             cnt = shortbuffered;
4459             shortbuffered = 0;
4460             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4461             SvCUR_set(sv, bpx);
4462             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4463             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4464             continue;
4465         }
4466
4467         DEBUG_P(PerlIO_printf(Perl_debug_log,
4468                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4469                               PTR2UV(ptr),(long)cnt));
4470         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4471         DEBUG_P(PerlIO_printf(Perl_debug_log,
4472             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4473             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4474             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4475         /* This used to call 'filbuf' in stdio form, but as that behaves like
4476            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4477            another abstraction.  */
4478         i   = PerlIO_getc(fp);          /* get more characters */
4479         DEBUG_P(PerlIO_printf(Perl_debug_log,
4480             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4481             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4482             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4483         cnt = PerlIO_get_cnt(fp);
4484         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
4485         DEBUG_P(PerlIO_printf(Perl_debug_log,
4486             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4487
4488         if (i == EOF)                   /* all done for ever? */
4489             goto thats_really_all_folks;
4490
4491         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4492         SvCUR_set(sv, bpx);
4493         SvGROW(sv, bpx + cnt + 2);
4494         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4495
4496         *bp++ = i;                      /* store character from PerlIO_getc */
4497
4498         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
4499             goto thats_all_folks;
4500     }
4501
4502 thats_all_folks:
4503     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4504           memNE((char*)bp - rslen, rsptr, rslen))
4505         goto screamer;                          /* go back to the fray */
4506 thats_really_all_folks:
4507     if (shortbuffered)
4508         cnt += shortbuffered;
4509         DEBUG_P(PerlIO_printf(Perl_debug_log,
4510             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4511     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
4512     DEBUG_P(PerlIO_printf(Perl_debug_log,
4513         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4514         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4515         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4516     *bp = '\0';
4517     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
4518     DEBUG_P(PerlIO_printf(Perl_debug_log,
4519         "Screamer: done, len=%ld, string=|%.*s|\n",
4520         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4521     }
4522    else
4523     {
4524 #ifndef EPOC
4525        /*The big, slow, and stupid way */
4526         STDCHAR buf[8192];
4527 #else
4528         /* Need to work around EPOC SDK features          */
4529         /* On WINS: MS VC5 generates calls to _chkstk,    */
4530         /* if a `large' stack frame is allocated          */
4531         /* gcc on MARM does not generate calls like these */
4532         STDCHAR buf[1024];
4533 #endif
4534
4535 screamer2:
4536         if (rslen) {
4537             register STDCHAR *bpe = buf + sizeof(buf);
4538             bp = buf;
4539             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4540                 ; /* keep reading */
4541             cnt = bp - buf;
4542         }
4543         else {
4544             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4545             /* Accomodate broken VAXC compiler, which applies U8 cast to
4546              * both args of ?: operator, causing EOF to change into 255
4547              */
4548             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4549         }
4550
4551         if (append)
4552             sv_catpvn(sv, (char *) buf, cnt);
4553         else
4554             sv_setpvn(sv, (char *) buf, cnt);
4555
4556         if (i != EOF &&                 /* joy */
4557             (!rslen ||
4558              SvCUR(sv) < rslen ||
4559              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4560         {
4561             append = -1;
4562             /*
4563              * If we're reading from a TTY and we get a short read,
4564              * indicating that the user hit his EOF character, we need
4565              * to notice it now, because if we try to read from the TTY
4566              * again, the EOF condition will disappear.
4567              *
4568              * The comparison of cnt to sizeof(buf) is an optimization
4569              * that prevents unnecessary calls to feof().
4570              *
4571              * - jik 9/25/96
4572              */
4573             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4574                 goto screamer2;
4575         }
4576     }
4577
4578     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
4579         while (i != EOF) {      /* to make sure file boundaries work right */
4580             i = PerlIO_getc(fp);
4581             if (i != '\n') {
4582                 PerlIO_ungetc(fp,i);
4583                 break;
4584             }
4585         }
4586     }
4587
4588     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4589 }
4590
4591
4592 /*
4593 =for apidoc sv_inc
4594
4595 Auto-increment of the value in the SV.
4596
4597 =cut
4598 */
4599
4600 void
4601 Perl_sv_inc(pTHX_ register SV *sv)
4602 {
4603     register char *d;
4604     int flags;
4605
4606     if (!sv)
4607         return;
4608     if (SvGMAGICAL(sv))
4609         mg_get(sv);
4610     if (SvTHINKFIRST(sv)) {
4611         if (SvREADONLY(sv)) {
4612             dTHR;
4613             if (PL_curcop != &PL_compiling)
4614                 Perl_croak(aTHX_ PL_no_modify);
4615         }
4616         if (SvROK(sv)) {
4617             IV i;
4618             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4619                 return;
4620             i = PTR2IV(SvRV(sv));
4621             sv_unref(sv);
4622             sv_setiv(sv, i);
4623         }
4624     }
4625     flags = SvFLAGS(sv);
4626     if (flags & SVp_NOK) {
4627         (void)SvNOK_only(sv);
4628         SvNVX(sv) += 1.0;
4629         return;
4630     }
4631     if (flags & SVp_IOK) {
4632         if (SvIsUV(sv)) {
4633             if (SvUVX(sv) == UV_MAX)
4634                 sv_setnv(sv, (NV)UV_MAX + 1.0);
4635             else
4636                 (void)SvIOK_only_UV(sv);
4637                 ++SvUVX(sv);
4638         } else {
4639             if (SvIVX(sv) == IV_MAX)
4640                 sv_setnv(sv, (NV)IV_MAX + 1.0);
4641             else {
4642                 (void)SvIOK_only(sv);
4643                 ++SvIVX(sv);
4644             }
4645         }
4646         return;
4647     }
4648     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4649         if ((flags & SVTYPEMASK) < SVt_PVNV)
4650             sv_upgrade(sv, SVt_NV);
4651         SvNVX(sv) = 1.0;
4652         (void)SvNOK_only(sv);
4653         return;
4654     }
4655     d = SvPVX(sv);
4656     while (isALPHA(*d)) d++;
4657     while (isDIGIT(*d)) d++;
4658     if (*d) {
4659         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);  /* punt */
4660         return;
4661     }
4662     d--;
4663     while (d >= SvPVX(sv)) {
4664         if (isDIGIT(*d)) {
4665             if (++*d <= '9')
4666                 return;
4667             *(d--) = '0';
4668         }
4669         else {
4670 #ifdef EBCDIC
4671             /* MKS: The original code here died if letters weren't consecutive.
4672              * at least it didn't have to worry about non-C locales.  The
4673              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4674              * arranged in order (although not consecutively) and that only
4675              * [A-Za-z] are accepted by isALPHA in the C locale.
4676              */
4677             if (*d != 'z' && *d != 'Z') {
4678                 do { ++*d; } while (!isALPHA(*d));
4679                 return;
4680             }
4681             *(d--) -= 'z' - 'a';
4682 #else
4683             ++*d;
4684             if (isALPHA(*d))
4685                 return;
4686             *(d--) -= 'z' - 'a' + 1;
4687 #endif
4688         }
4689     }
4690     /* oh,oh, the number grew */
4691     SvGROW(sv, SvCUR(sv) + 2);
4692     SvCUR(sv)++;
4693     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4694         *d = d[-1];
4695     if (isDIGIT(d[1]))
4696         *d = '1';
4697     else
4698         *d = d[1];
4699 }
4700
4701 /*
4702 =for apidoc sv_dec
4703
4704 Auto-decrement of the value in the SV.
4705
4706 =cut
4707 */
4708
4709 void
4710 Perl_sv_dec(pTHX_ register SV *sv)
4711 {
4712     int flags;
4713
4714     if (!sv)
4715         return;
4716     if (SvGMAGICAL(sv))
4717         mg_get(sv);
4718     if (SvTHINKFIRST(sv)) {
4719         if (SvREADONLY(sv)) {
4720             dTHR;
4721             if (PL_curcop != &PL_compiling)
4722                 Perl_croak(aTHX_ PL_no_modify);
4723         }
4724         if (SvROK(sv)) {
4725             IV i;
4726             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4727                 return;
4728             i = PTR2IV(SvRV(sv));
4729             sv_unref(sv);
4730             sv_setiv(sv, i);
4731         }
4732     }
4733     flags = SvFLAGS(sv);
4734     if (flags & SVp_NOK) {
4735         SvNVX(sv) -= 1.0;
4736         (void)SvNOK_only(sv);
4737         return;
4738     }
4739     if (flags & SVp_IOK) {
4740         if (SvIsUV(sv)) {
4741             if (SvUVX(sv) == 0) {
4742                 (void)SvIOK_only(sv);
4743                 SvIVX(sv) = -1;
4744             }
4745             else {
4746                 (void)SvIOK_only_UV(sv);
4747                 --SvUVX(sv);
4748             }
4749         } else {
4750             if (SvIVX(sv) == IV_MIN)
4751                 sv_setnv(sv, (NV)IV_MIN - 1.0);
4752             else {
4753                 (void)SvIOK_only(sv);
4754                 --SvIVX(sv);
4755             }
4756         }
4757         return;
4758     }
4759     if (!(flags & SVp_POK)) {
4760         if ((flags & SVTYPEMASK) < SVt_PVNV)
4761             sv_upgrade(sv, SVt_NV);
4762         SvNVX(sv) = -1.0;
4763         (void)SvNOK_only(sv);
4764         return;
4765     }
4766     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4767 }
4768
4769 /*
4770 =for apidoc sv_mortalcopy
4771
4772 Creates a new SV which is a copy of the original SV.  The new SV is marked
4773 as mortal.
4774
4775 =cut
4776 */
4777
4778 /* Make a string that will exist for the duration of the expression
4779  * evaluation.  Actually, it may have to last longer than that, but
4780  * hopefully we won't free it until it has been assigned to a
4781  * permanent location. */
4782
4783 SV *
4784 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4785 {
4786     dTHR;
4787     register SV *sv;
4788
4789     new_SV(sv);
4790     sv_setsv(sv,oldstr);
4791     EXTEND_MORTAL(1);
4792     PL_tmps_stack[++PL_tmps_ix] = sv;
4793     SvTEMP_on(sv);
4794     return sv;
4795 }
4796
4797 /*
4798 =for apidoc sv_newmortal
4799
4800 Creates a new SV which is mortal.  The reference count of the SV is set to 1.
4801
4802 =cut
4803 */
4804
4805 SV *
4806 Perl_sv_newmortal(pTHX)
4807 {
4808     dTHR;
4809     register SV *sv;
4810
4811     new_SV(sv);
4812     SvFLAGS(sv) = SVs_TEMP;
4813     EXTEND_MORTAL(1);
4814     PL_tmps_stack[++PL_tmps_ix] = sv;
4815     return sv;
4816 }
4817
4818 /*
4819 =for apidoc sv_2mortal
4820
4821 Marks an SV as mortal.  The SV will be destroyed when the current context
4822 ends.
4823
4824 =cut
4825 */
4826
4827 /* same thing without the copying */
4828
4829 SV *
4830 Perl_sv_2mortal(pTHX_ register SV *sv)
4831 {
4832     dTHR;
4833     if (!sv)
4834         return sv;
4835     if (SvREADONLY(sv) && SvIMMORTAL(sv))
4836         return sv;
4837     EXTEND_MORTAL(1);
4838     PL_tmps_stack[++PL_tmps_ix] = sv;
4839     SvTEMP_on(sv);
4840     return sv;
4841 }
4842
4843 /*
4844 =for apidoc newSVpv
4845
4846 Creates a new SV and copies a string into it.  The reference count for the
4847 SV is set to 1.  If C<len> is zero, Perl will compute the length using
4848 strlen().  For efficiency, consider using C<newSVpvn> instead.
4849
4850 =cut
4851 */
4852
4853 SV *
4854 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4855 {
4856     register SV *sv;
4857
4858     new_SV(sv);
4859     if (!len)
4860         len = strlen(s);
4861     sv_setpvn(sv,s,len);
4862     return sv;
4863 }
4864
4865 /*
4866 =for apidoc newSVpvn
4867
4868 Creates a new SV and copies a string into it.  The reference count for the
4869 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
4870 string.  You are responsible for ensuring that the source string is at least
4871 C<len> bytes long.
4872
4873 =cut
4874 */
4875
4876 SV *
4877 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4878 {
4879     register SV *sv;
4880
4881     new_SV(sv);
4882     sv_setpvn(sv,s,len);
4883     return sv;
4884 }
4885
4886 /*
4887 =for apidoc newSVpvn_share
4888
4889 Creates a new SV and populates it with a string from
4890 the string table. Turns on READONLY and FAKE.
4891 The idea here is that as string table is used for shared hash
4892 keys these strings will have SvPVX == HeKEY and hash lookup
4893 will avoid string compare.
4894
4895 =cut
4896 */
4897
4898 SV *
4899 Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash)
4900 {
4901     register SV *sv;
4902     if (!hash)
4903         PERL_HASH(hash, src, len);
4904     new_SV(sv);
4905     sv_upgrade(sv, SVt_PVIV);
4906     SvPVX(sv) = sharepvn(src, len, hash);
4907     SvCUR(sv) = len;
4908     SvUVX(sv) = hash;
4909     SvLEN(sv) = 0;
4910     SvREADONLY_on(sv);
4911     SvFAKE_on(sv);
4912     SvPOK_on(sv);
4913     return sv;
4914 }
4915
4916 #if defined(PERL_IMPLICIT_CONTEXT)
4917 SV *
4918 Perl_newSVpvf_nocontext(const char* pat, ...)
4919 {
4920     dTHX;
4921     register SV *sv;
4922     va_list args;
4923     va_start(args, pat);
4924     sv = vnewSVpvf(pat, &args);
4925     va_end(args);
4926     return sv;
4927 }
4928 #endif
4929
4930 /*
4931 =for apidoc newSVpvf
4932
4933 Creates a new SV an initialize it with the string formatted like
4934 C<sprintf>.
4935
4936 =cut
4937 */
4938
4939 SV *
4940 Perl_newSVpvf(pTHX_ const char* pat, ...)
4941 {
4942     register SV *sv;
4943     va_list args;
4944     va_start(args, pat);
4945     sv = vnewSVpvf(pat, &args);
4946     va_end(args);
4947     return sv;
4948 }
4949
4950 SV *
4951 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4952 {
4953     register SV *sv;
4954     new_SV(sv);
4955     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4956     return sv;
4957 }
4958
4959 /*
4960 =for apidoc newSVnv
4961
4962 Creates a new SV and copies a floating point value into it.
4963 The reference count for the SV is set to 1.
4964
4965 =cut
4966 */
4967
4968 SV *
4969 Perl_newSVnv(pTHX_ NV n)
4970 {
4971     register SV *sv;
4972
4973     new_SV(sv);
4974     sv_setnv(sv,n);
4975     return sv;
4976 }
4977
4978 /*
4979 =for apidoc newSViv
4980
4981 Creates a new SV and copies an integer into it.  The reference count for the
4982 SV is set to 1.
4983
4984 =cut
4985 */
4986
4987 SV *
4988 Perl_newSViv(pTHX_ IV i)
4989 {
4990     register SV *sv;
4991
4992     new_SV(sv);
4993     sv_setiv(sv,i);
4994     return sv;
4995 }
4996
4997 /*
4998 =for apidoc newSVuv
4999
5000 Creates a new SV and copies an unsigned integer into it.
5001 The reference count for the SV is set to 1.
5002
5003 =cut
5004 */
5005
5006 SV *
5007 Perl_newSVuv(pTHX_ UV u)
5008 {
5009     register SV *sv;
5010
5011     new_SV(sv);
5012     sv_setuv(sv,u);
5013     return sv;
5014 }
5015
5016 /*
5017 =for apidoc newRV_noinc
5018
5019 Creates an RV wrapper for an SV.  The reference count for the original
5020 SV is B<not> incremented.
5021
5022 =cut
5023 */
5024
5025 SV *
5026 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5027 {
5028     dTHR;
5029     register SV *sv;
5030
5031     new_SV(sv);
5032     sv_upgrade(sv, SVt_RV);
5033     SvTEMP_off(tmpRef);
5034     SvRV(sv) = tmpRef;
5035     SvROK_on(sv);
5036     return sv;
5037 }
5038
5039 /* newRV_inc is #defined to newRV in sv.h */
5040 SV *
5041 Perl_newRV(pTHX_ SV *tmpRef)
5042 {
5043     return newRV_noinc(SvREFCNT_inc(tmpRef));
5044 }
5045
5046 /*
5047 =for apidoc newSVsv
5048
5049 Creates a new SV which is an exact duplicate of the original SV.
5050
5051 =cut
5052 */
5053
5054 /* make an exact duplicate of old */
5055
5056 SV *
5057 Perl_newSVsv(pTHX_ register SV *old)
5058 {
5059     dTHR;
5060     register SV *sv;
5061
5062     if (!old)
5063         return Nullsv;
5064     if (SvTYPE(old) == SVTYPEMASK) {
5065         if (ckWARN_d(WARN_INTERNAL))
5066             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5067         return Nullsv;
5068     }
5069     new_SV(sv);
5070     if (SvTEMP(old)) {
5071         SvTEMP_off(old);
5072         sv_setsv(sv,old);
5073         SvTEMP_on(old);
5074     }
5075     else
5076         sv_setsv(sv,old);
5077     return sv;
5078 }
5079
5080 void
5081 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5082 {
5083     register HE *entry;
5084     register GV *gv;
5085     register SV *sv;
5086     register I32 i;
5087     register PMOP *pm;
5088     register I32 max;
5089     char todo[PERL_UCHAR_MAX+1];
5090
5091     if (!stash)
5092         return;
5093
5094     if (!*s) {          /* reset ?? searches */
5095         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5096             pm->op_pmdynflags &= ~PMdf_USED;
5097         }
5098         return;
5099     }
5100
5101     /* reset variables */
5102
5103     if (!HvARRAY(stash))
5104         return;
5105
5106     Zero(todo, 256, char);
5107     while (*s) {
5108         i = (unsigned char)*s;
5109         if (s[1] == '-') {
5110             s += 2;
5111         }
5112         max = (unsigned char)*s++;
5113         for ( ; i <= max; i++) {
5114             todo[i] = 1;
5115         }
5116         for (i = 0; i <= (I32) HvMAX(stash); i++) {
5117             for (entry = HvARRAY(stash)[i];
5118                  entry;
5119                  entry = HeNEXT(entry))
5120             {
5121                 if (!todo[(U8)*HeKEY(entry)])
5122                     continue;
5123                 gv = (GV*)HeVAL(entry);
5124                 sv = GvSV(gv);
5125                 if (SvTHINKFIRST(sv)) {
5126                     if (!SvREADONLY(sv) && SvROK(sv))
5127                         sv_unref(sv);
5128                     continue;
5129                 }
5130                 (void)SvOK_off(sv);
5131                 if (SvTYPE(sv) >= SVt_PV) {
5132                     SvCUR_set(sv, 0);
5133                     if (SvPVX(sv) != Nullch)
5134                         *SvPVX(sv) = '\0';
5135                     SvTAINT(sv);
5136                 }
5137                 if (GvAV(gv)) {
5138                     av_clear(GvAV(gv));
5139                 }
5140                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5141                     hv_clear(GvHV(gv));
5142 #ifdef USE_ENVIRON_ARRAY
5143                     if (gv == PL_envgv)
5144                         environ[0] = Nullch;
5145 #endif
5146                 }
5147             }
5148         }
5149     }
5150 }
5151
5152 IO*
5153 Perl_sv_2io(pTHX_ SV *sv)
5154 {
5155     IO* io;
5156     GV* gv;
5157     STRLEN n_a;
5158
5159     switch (SvTYPE(sv)) {
5160     case SVt_PVIO:
5161         io = (IO*)sv;
5162         break;
5163     case SVt_PVGV:
5164         gv = (GV*)sv;
5165         io = GvIO(gv);
5166         if (!io)
5167             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5168         break;
5169     default:
5170         if (!SvOK(sv))
5171             Perl_croak(aTHX_ PL_no_usym, "filehandle");
5172         if (SvROK(sv))
5173             return sv_2io(SvRV(sv));
5174         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5175         if (gv)
5176             io = GvIO(gv);
5177         else
5178             io = 0;
5179         if (!io)
5180             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5181         break;
5182     }
5183     return io;
5184 }
5185
5186 CV *
5187 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5188 {
5189     GV *gv;
5190     CV *cv;
5191     STRLEN n_a;
5192
5193     if (!sv)
5194         return *gvp = Nullgv, Nullcv;
5195     switch (SvTYPE(sv)) {
5196     case SVt_PVCV:
5197         *st = CvSTASH(sv);
5198         *gvp = Nullgv;
5199         return (CV*)sv;
5200     case SVt_PVHV:
5201     case SVt_PVAV:
5202         *gvp = Nullgv;
5203         return Nullcv;
5204     case SVt_PVGV:
5205         gv = (GV*)sv;
5206         *gvp = gv;
5207         *st = GvESTASH(gv);
5208         goto fix_gv;
5209
5210     default:
5211         if (SvGMAGICAL(sv))
5212             mg_get(sv);
5213         if (SvROK(sv)) {
5214             dTHR;
5215             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
5216             tryAMAGICunDEREF(to_cv);
5217
5218             sv = SvRV(sv);
5219             if (SvTYPE(sv) == SVt_PVCV) {
5220                 cv = (CV*)sv;
5221                 *gvp = Nullgv;
5222                 *st = CvSTASH(cv);
5223                 return cv;
5224             }
5225             else if(isGV(sv))
5226                 gv = (GV*)sv;
5227             else
5228                 Perl_croak(aTHX_ "Not a subroutine reference");
5229         }
5230         else if (isGV(sv))
5231             gv = (GV*)sv;
5232         else
5233             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5234         *gvp = gv;
5235         if (!gv)
5236             return Nullcv;
5237         *st = GvESTASH(gv);
5238     fix_gv:
5239         if (lref && !GvCVu(gv)) {
5240             SV *tmpsv;
5241             ENTER;
5242             tmpsv = NEWSV(704,0);
5243             gv_efullname3(tmpsv, gv, Nullch);
5244             /* XXX this is probably not what they think they're getting.
5245              * It has the same effect as "sub name;", i.e. just a forward
5246              * declaration! */
5247             newSUB(start_subparse(FALSE, 0),
5248                    newSVOP(OP_CONST, 0, tmpsv),
5249                    Nullop,
5250                    Nullop);
5251             LEAVE;
5252             if (!GvCVu(gv))
5253                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5254         }
5255         return GvCVu(gv);
5256     }
5257 }
5258
5259 /*
5260 =for apidoc sv_true
5261
5262 Returns true if the SV has a true value by Perl's rules.
5263
5264 =cut
5265 */
5266
5267 I32
5268 Perl_sv_true(pTHX_ register SV *sv)
5269 {
5270     dTHR;
5271     if (!sv)
5272         return 0;
5273     if (SvPOK(sv)) {
5274         register XPV* tXpv;
5275         if ((tXpv = (XPV*)SvANY(sv)) &&
5276                 (tXpv->xpv_cur > 1 ||
5277                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5278             return 1;
5279         else
5280             return 0;
5281     }
5282     else {
5283         if (SvIOK(sv))
5284             return SvIVX(sv) != 0;
5285         else {
5286             if (SvNOK(sv))
5287                 return SvNVX(sv) != 0.0;
5288             else
5289                 return sv_2bool(sv);
5290         }
5291     }
5292 }
5293
5294 IV
5295 Perl_sv_iv(pTHX_ register SV *sv)
5296 {
5297     if (SvIOK(sv)) {
5298         if (SvIsUV(sv))
5299             return (IV)SvUVX(sv);
5300         return SvIVX(sv);
5301     }
5302     return sv_2iv(sv);
5303 }
5304
5305 UV
5306 Perl_sv_uv(pTHX_ register SV *sv)
5307 {
5308     if (SvIOK(sv)) {
5309         if (SvIsUV(sv))
5310             return SvUVX(sv);
5311         return (UV)SvIVX(sv);
5312     }
5313     return sv_2uv(sv);
5314 }
5315
5316 NV
5317 Perl_sv_nv(pTHX_ register SV *sv)
5318 {
5319     if (SvNOK(sv))
5320         return SvNVX(sv);
5321     return sv_2nv(sv);
5322 }
5323
5324 char *
5325 Perl_sv_pv(pTHX_ SV *sv)
5326 {
5327     STRLEN n_a;
5328
5329     if (SvPOK(sv))
5330         return SvPVX(sv);
5331
5332     return sv_2pv(sv, &n_a);
5333 }
5334
5335 char *
5336 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5337 {
5338     if (SvPOK(sv)) {
5339         *lp = SvCUR(sv);
5340         return SvPVX(sv);
5341     }
5342     return sv_2pv(sv, lp);
5343 }
5344
5345 /*
5346 =for apidoc sv_pvn_force
5347
5348 Get a sensible string out of the SV somehow.
5349
5350 =cut
5351 */
5352
5353 char *
5354 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5355 {
5356     char *s;
5357
5358     if (SvTHINKFIRST(sv) && !SvROK(sv))
5359         sv_force_normal(sv);
5360
5361     if (SvPOK(sv)) {
5362         *lp = SvCUR(sv);
5363     }
5364     else {
5365         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5366             dTHR;
5367             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5368                 PL_op_name[PL_op->op_type]);
5369         }
5370         else
5371             s = sv_2pv(sv, lp);
5372         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
5373             STRLEN len = *lp;
5374
5375             if (SvROK(sv))
5376                 sv_unref(sv);
5377             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
5378             SvGROW(sv, len + 1);
5379             Move(s,SvPVX(sv),len,char);
5380             SvCUR_set(sv, len);
5381             *SvEND(sv) = '\0';
5382         }
5383         if (!SvPOK(sv)) {
5384             SvPOK_on(sv);               /* validate pointer */
5385             SvTAINT(sv);
5386             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5387                                   PTR2UV(sv),SvPVX(sv)));
5388         }
5389     }
5390     return SvPVX(sv);
5391 }
5392
5393 char *
5394 Perl_sv_pvbyte(pTHX_ SV *sv)
5395 {
5396     return sv_pv(sv);
5397 }
5398
5399 char *
5400 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5401 {
5402     return sv_pvn(sv,lp);
5403 }
5404
5405 char *
5406 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5407 {
5408     return sv_pvn_force(sv,lp);
5409 }
5410
5411 char *
5412 Perl_sv_pvutf8(pTHX_ SV *sv)
5413 {
5414     sv_utf8_upgrade(sv);
5415     return sv_pv(sv);
5416 }
5417
5418 char *
5419 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5420 {
5421     sv_utf8_upgrade(sv);
5422     return sv_pvn(sv,lp);
5423 }
5424
5425 /*
5426 =for apidoc sv_pvutf8n_force
5427
5428 Get a sensible UTF8-encoded string out of the SV somehow. See
5429 L</sv_pvn_force>.
5430
5431 =cut
5432 */
5433
5434 char *
5435 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5436 {
5437     sv_utf8_upgrade(sv);
5438     return sv_pvn_force(sv,lp);
5439 }
5440
5441 /*
5442 =for apidoc sv_reftype
5443
5444 Returns a string describing what the SV is a reference to.
5445
5446 =cut
5447 */
5448
5449 char *
5450 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5451 {
5452     if (ob && SvOBJECT(sv))
5453         return HvNAME(SvSTASH(sv));
5454     else {
5455         switch (SvTYPE(sv)) {
5456         case SVt_NULL:
5457         case SVt_IV:
5458         case SVt_NV:
5459         case SVt_RV:
5460         case SVt_PV:
5461         case SVt_PVIV:
5462         case SVt_PVNV:
5463         case SVt_PVMG:
5464         case SVt_PVBM:
5465                                 if (SvROK(sv))
5466                                     return "REF";
5467                                 else
5468                                     return "SCALAR";
5469         case SVt_PVLV:          return "LVALUE";
5470         case SVt_PVAV:          return "ARRAY";
5471         case SVt_PVHV:          return "HASH";
5472         case SVt_PVCV:          return "CODE";
5473         case SVt_PVGV:          return "GLOB";
5474         case SVt_PVFM:          return "FORMAT";
5475         case SVt_PVIO:          return "IO";
5476         default:                return "UNKNOWN";
5477         }
5478     }
5479 }
5480
5481 /*
5482 =for apidoc sv_isobject
5483
5484 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5485 object.  If the SV is not an RV, or if the object is not blessed, then this
5486 will return false.
5487
5488 =cut
5489 */
5490
5491 int
5492 Perl_sv_isobject(pTHX_ SV *sv)
5493 {
5494     if (!sv)
5495         return 0;
5496     if (SvGMAGICAL(sv))
5497         mg_get(sv);
5498     if (!SvROK(sv))
5499         return 0;
5500     sv = (SV*)SvRV(sv);
5501     if (!SvOBJECT(sv))
5502         return 0;
5503     return 1;
5504 }
5505
5506 /*
5507 =for apidoc sv_isa
5508
5509 Returns a boolean indicating whether the SV is blessed into the specified
5510 class.  This does not check for subtypes; use C<sv_derived_from> to verify
5511 an inheritance relationship.
5512
5513 =cut
5514 */
5515
5516 int
5517 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5518 {
5519     if (!sv)
5520         return 0;
5521     if (SvGMAGICAL(sv))
5522         mg_get(sv);
5523     if (!SvROK(sv))
5524         return 0;
5525     sv = (SV*)SvRV(sv);
5526     if (!SvOBJECT(sv))
5527         return 0;
5528
5529     return strEQ(HvNAME(SvSTASH(sv)), name);
5530 }
5531
5532 /*
5533 =for apidoc newSVrv
5534
5535 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
5536 it will be upgraded to one.  If C<classname> is non-null then the new SV will
5537 be blessed in the specified package.  The new SV is returned and its
5538 reference count is 1.
5539
5540 =cut
5541 */
5542
5543 SV*
5544 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5545 {
5546     dTHR;
5547     SV *sv;
5548
5549     new_SV(sv);
5550
5551     SV_CHECK_THINKFIRST(rv);
5552     SvAMAGIC_off(rv);
5553
5554     if (SvTYPE(rv) >= SVt_PVMG) {
5555         U32 refcnt = SvREFCNT(rv);
5556         SvREFCNT(rv) = 0;
5557         sv_clear(rv);
5558         SvFLAGS(rv) = 0;
5559         SvREFCNT(rv) = refcnt;
5560     }
5561
5562     if (SvTYPE(rv) < SVt_RV)
5563         sv_upgrade(rv, SVt_RV);
5564     else if (SvTYPE(rv) > SVt_RV) {
5565         (void)SvOOK_off(rv);
5566         if (SvPVX(rv) && SvLEN(rv))
5567             Safefree(SvPVX(rv));
5568         SvCUR_set(rv, 0);
5569         SvLEN_set(rv, 0);
5570     }
5571
5572     (void)SvOK_off(rv);
5573     SvRV(rv) = sv;
5574     SvROK_on(rv);
5575
5576     if (classname) {
5577         HV* stash = gv_stashpv(classname, TRUE);
5578         (void)sv_bless(rv, stash);
5579     }
5580     return sv;
5581 }
5582
5583 /*
5584 =for apidoc sv_setref_pv
5585
5586 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
5587 argument will be upgraded to an RV.  That RV will be modified to point to
5588 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5589 into the SV.  The C<classname> argument indicates the package for the
5590 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
5591 will be returned and will have a reference count of 1.
5592
5593 Do not use with other Perl types such as HV, AV, SV, CV, because those
5594 objects will become corrupted by the pointer copy process.
5595
5596 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5597
5598 =cut
5599 */
5600
5601 SV*
5602 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5603 {
5604     if (!pv) {
5605         sv_setsv(rv, &PL_sv_undef);
5606         SvSETMAGIC(rv);
5607     }
5608     else
5609         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5610     return rv;
5611 }
5612
5613 /*
5614 =for apidoc sv_setref_iv
5615
5616 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
5617 argument will be upgraded to an RV.  That RV will be modified to point to
5618 the new SV.  The C<classname> argument indicates the package for the
5619 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
5620 will be returned and will have a reference count of 1.
5621
5622 =cut
5623 */
5624
5625 SV*
5626 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5627 {
5628     sv_setiv(newSVrv(rv,classname), iv);
5629     return rv;
5630 }
5631
5632 /*
5633 =for apidoc sv_setref_nv
5634
5635 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
5636 argument will be upgraded to an RV.  That RV will be modified to point to
5637 the new SV.  The C<classname> argument indicates the package for the
5638 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
5639 will be returned and will have a reference count of 1.
5640
5641 =cut
5642 */
5643
5644 SV*
5645 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5646 {
5647     sv_setnv(newSVrv(rv,classname), nv);
5648     return rv;
5649 }
5650
5651 /*
5652 =for apidoc sv_setref_pvn
5653
5654 Copies a string into a new SV, optionally blessing the SV.  The length of the
5655 string must be specified with C<n>.  The C<rv> argument will be upgraded to
5656 an RV.  That RV will be modified to point to the new SV.  The C<classname>
5657 argument indicates the package for the blessing.  Set C<classname> to
5658 C<Nullch> to avoid the blessing.  The new SV will be returned and will have
5659 a reference count of 1.
5660
5661 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5662
5663 =cut
5664 */
5665
5666 SV*
5667 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5668 {
5669     sv_setpvn(newSVrv(rv,classname), pv, n);
5670     return rv;
5671 }
5672
5673 /*
5674 =for apidoc sv_bless
5675
5676 Blesses an SV into a specified package.  The SV must be an RV.  The package
5677 must be designated by its stash (see C<gv_stashpv()>).  The reference count
5678 of the SV is unaffected.
5679
5680 =cut
5681 */
5682
5683 SV*
5684 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5685 {
5686     dTHR;
5687     SV *tmpRef;
5688     if (!SvROK(sv))
5689         Perl_croak(aTHX_ "Can't bless non-reference value");
5690     tmpRef = SvRV(sv);
5691     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5692         if (SvREADONLY(tmpRef))
5693             Perl_croak(aTHX_ PL_no_modify);
5694         if (SvOBJECT(tmpRef)) {
5695             if (SvTYPE(tmpRef) != SVt_PVIO)
5696                 --PL_sv_objcount;
5697             SvREFCNT_dec(SvSTASH(tmpRef));
5698         }
5699     }
5700     SvOBJECT_on(tmpRef);
5701     if (SvTYPE(tmpRef) != SVt_PVIO)
5702         ++PL_sv_objcount;
5703     (void)SvUPGRADE(tmpRef, SVt_PVMG);
5704     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5705
5706     if (Gv_AMG(stash))
5707         SvAMAGIC_on(sv);
5708     else
5709         SvAMAGIC_off(sv);
5710
5711     return sv;
5712 }
5713
5714 STATIC void
5715 S_sv_unglob(pTHX_ SV *sv)
5716 {
5717     void *xpvmg;
5718
5719     assert(SvTYPE(sv) == SVt_PVGV);
5720     SvFAKE_off(sv);
5721     if (GvGP(sv))
5722         gp_free((GV*)sv);
5723     if (GvSTASH(sv)) {
5724         SvREFCNT_dec(GvSTASH(sv));
5725         GvSTASH(sv) = Nullhv;
5726     }
5727     sv_unmagic(sv, '*');
5728     Safefree(GvNAME(sv));
5729     GvMULTI_off(sv);
5730
5731     /* need to keep SvANY(sv) in the right arena */
5732     xpvmg = new_XPVMG();
5733     StructCopy(SvANY(sv), xpvmg, XPVMG);
5734     del_XPVGV(SvANY(sv));
5735     SvANY(sv) = xpvmg;
5736
5737     SvFLAGS(sv) &= ~SVTYPEMASK;
5738     SvFLAGS(sv) |= SVt_PVMG;
5739 }
5740
5741 /*
5742 =for apidoc sv_unref
5743
5744 Unsets the RV status of the SV, and decrements the reference count of
5745 whatever was being referenced by the RV.  This can almost be thought of
5746 as a reversal of C<newSVrv>.  See C<SvROK_off>.
5747
5748 =cut
5749 */
5750
5751 void
5752 Perl_sv_unref(pTHX_ SV *sv)
5753 {
5754     SV* rv = SvRV(sv);
5755
5756     if (SvWEAKREF(sv)) {
5757         sv_del_backref(sv);
5758         SvWEAKREF_off(sv);
5759         SvRV(sv) = 0;
5760         return;
5761     }
5762     SvRV(sv) = 0;
5763     SvROK_off(sv);
5764     if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5765         SvREFCNT_dec(rv);
5766     else
5767         sv_2mortal(rv);         /* Schedule for freeing later */
5768 }
5769
5770 void
5771 Perl_sv_taint(pTHX_ SV *sv)
5772 {
5773     sv_magic((sv), Nullsv, 't', Nullch, 0);
5774 }
5775
5776 void
5777 Perl_sv_untaint(pTHX_ SV *sv)
5778 {
5779     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5780         MAGIC *mg = mg_find(sv, 't');
5781         if (mg)
5782             mg->mg_len &= ~1;
5783     }
5784 }
5785
5786 bool
5787 Perl_sv_tainted(pTHX_ SV *sv)
5788 {
5789     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5790         MAGIC *mg = mg_find(sv, 't');
5791         if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5792             return TRUE;
5793     }
5794     return FALSE;
5795 }
5796
5797 /*
5798 =for apidoc sv_setpviv
5799
5800 Copies an integer into the given SV, also updating its string value.
5801 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
5802
5803 =cut
5804 */
5805
5806 void
5807 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5808 {
5809     char buf[TYPE_CHARS(UV)];
5810     char *ebuf;
5811     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5812
5813     sv_setpvn(sv, ptr, ebuf - ptr);
5814 }
5815
5816
5817 /*
5818 =for apidoc sv_setpviv_mg
5819
5820 Like C<sv_setpviv>, but also handles 'set' magic.
5821
5822 =cut
5823 */
5824
5825 void
5826 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5827 {
5828     char buf[TYPE_CHARS(UV)];
5829     char *ebuf;
5830     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5831
5832     sv_setpvn(sv, ptr, ebuf - ptr);
5833     SvSETMAGIC(sv);
5834 }
5835
5836 #if defined(PERL_IMPLICIT_CONTEXT)
5837 void
5838 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5839 {
5840     dTHX;
5841     va_list args;
5842     va_start(args, pat);
5843     sv_vsetpvf(sv, pat, &args);
5844     va_end(args);
5845 }
5846
5847
5848 void
5849 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5850 {
5851     dTHX;
5852     va_list args;
5853     va_start(args, pat);
5854     sv_vsetpvf_mg(sv, pat, &args);
5855     va_end(args);
5856 }
5857 #endif
5858
5859 /*
5860 =for apidoc sv_setpvf
5861
5862 Processes its arguments like C<sprintf> and sets an SV to the formatted
5863 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
5864
5865 =cut
5866 */
5867
5868 void
5869 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5870 {
5871     va_list args;
5872     va_start(args, pat);
5873     sv_vsetpvf(sv, pat, &args);
5874     va_end(args);
5875 }
5876
5877 void
5878 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5879 {
5880     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5881 }
5882
5883 /*
5884 =for apidoc sv_setpvf_mg
5885
5886 Like C<sv_setpvf>, but also handles 'set' magic.
5887
5888 =cut
5889 */
5890
5891 void
5892 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5893 {
5894     va_list args;
5895     va_start(args, pat);
5896     sv_vsetpvf_mg(sv, pat, &args);
5897     va_end(args);
5898 }
5899
5900 void
5901 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5902 {
5903     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5904     SvSETMAGIC(sv);
5905 }
5906
5907 #if defined(PERL_IMPLICIT_CONTEXT)
5908 void
5909 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5910 {
5911     dTHX;
5912     va_list args;
5913     va_start(args, pat);
5914     sv_vcatpvf(sv, pat, &args);
5915     va_end(args);
5916 }
5917
5918 void
5919 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5920 {
5921     dTHX;
5922     va_list args;
5923     va_start(args, pat);
5924     sv_vcatpvf_mg(sv, pat, &args);
5925     va_end(args);
5926 }
5927 #endif
5928
5929 /*
5930 =for apidoc sv_catpvf
5931
5932 Processes its arguments like C<sprintf> and appends the formatted output
5933 to an SV.  Handles 'get' magic, but not 'set' magic.  C<SvSETMAGIC()> must
5934 typically be called after calling this function to handle 'set' magic.
5935
5936 =cut
5937 */
5938
5939 void
5940 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5941 {
5942     va_list args;
5943     va_start(args, pat);
5944     sv_vcatpvf(sv, pat, &args);
5945     va_end(args);
5946 }
5947
5948 void
5949 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5950 {
5951     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5952 }
5953
5954 /*
5955 =for apidoc sv_catpvf_mg
5956
5957 Like C<sv_catpvf>, but also handles 'set' magic.
5958
5959 =cut
5960 */
5961
5962 void
5963 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5964 {
5965     va_list args;
5966     va_start(args, pat);
5967     sv_vcatpvf_mg(sv, pat, &args);
5968     va_end(args);
5969 }
5970
5971 void
5972 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5973 {
5974     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5975     SvSETMAGIC(sv);
5976 }
5977
5978 /*
5979 =for apidoc sv_vsetpvfn
5980
5981 Works like C<vcatpvfn> but copies the text into the SV instead of
5982 appending it.
5983
5984 =cut
5985 */
5986
5987 void
5988 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5989 {
5990     sv_setpvn(sv, "", 0);
5991     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5992 }
5993
5994 /*
5995 =for apidoc sv_vcatpvfn
5996
5997 Processes its arguments like C<vsprintf> and appends the formatted output
5998 to an SV.  Uses an array of SVs if the C style variable argument list is
5999 missing (NULL).  When running with taint checks enabled, indicates via
6000 C<maybe_tainted> if results are untrustworthy (often due to the use of
6001 locales).
6002
6003 =cut
6004 */
6005
6006 void
6007 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6008 {
6009     dTHR;
6010     char *p;
6011     char *q;
6012     char *patend;
6013     STRLEN origlen;
6014     I32 svix = 0;
6015     static char nullstr[] = "(null)";
6016     SV *argsv;
6017
6018     /* no matter what, this is a string now */
6019     (void)SvPV_force(sv, origlen);
6020
6021     /* special-case "", "%s", and "%_" */
6022     if (patlen == 0)
6023         return;
6024     if (patlen == 2 && pat[0] == '%') {
6025         switch (pat[1]) {
6026         case 's':
6027             if (args) {
6028                 char *s = va_arg(*args, char*);
6029                 sv_catpv(sv, s ? s : nullstr);
6030             }
6031             else if (svix < svmax) {
6032                 sv_catsv(sv, *svargs);
6033                 if (DO_UTF8(*svargs))
6034                     SvUTF8_on(sv);
6035             }
6036             return;
6037         case '_':
6038             if (args) {
6039                 argsv = va_arg(*args, SV*);
6040                 sv_catsv(sv, argsv);
6041                 if (DO_UTF8(argsv))
6042                     SvUTF8_on(sv);
6043                 return;
6044             }
6045             /* See comment on '_' below */
6046             break;
6047         }
6048     }
6049
6050     patend = (char*)pat + patlen;
6051     for (p = (char*)pat; p < patend; p = q) {
6052         bool alt = FALSE;
6053         bool left = FALSE;
6054         bool vectorize = FALSE;
6055         bool utf = FALSE;
6056         char fill = ' ';
6057         char plus = 0;
6058         char intsize = 0;
6059         STRLEN width = 0;
6060         STRLEN zeros = 0;
6061         bool has_precis = FALSE;
6062         STRLEN precis = 0;
6063         bool is_utf = FALSE;
6064
6065         char esignbuf[4];
6066         U8 utf8buf[UTF8_MAXLEN];
6067         STRLEN esignlen = 0;
6068
6069         char *eptr = Nullch;
6070         STRLEN elen = 0;
6071         /* Times 4: a decimal digit takes more than 3 binary digits.
6072          * NV_DIG: mantissa takes than many decimal digits.
6073          * Plus 32: Playing safe. */
6074         char ebuf[IV_DIG * 4 + NV_DIG + 32];
6075         /* large enough for "%#.#f" --chip */
6076         /* what about long double NVs? --jhi */
6077
6078         SV *vecsv;
6079         U8 *vecstr = Null(U8*);
6080         STRLEN veclen = 0;
6081         char c;
6082         int i;
6083         unsigned base;
6084         IV iv;
6085         UV uv;
6086         NV nv;
6087         STRLEN have;
6088         STRLEN need;
6089         STRLEN gap;
6090         char *dotstr = ".";
6091         STRLEN dotstrlen = 1;
6092         I32 epix = 0; /* explicit parameter index */
6093         I32 ewix = 0; /* explicit width index */
6094         bool asterisk = FALSE;
6095
6096         for (q = p; q < patend && *q != '%'; ++q) ;
6097         if (q > p) {
6098             sv_catpvn(sv, p, q - p);
6099             p = q;
6100         }
6101         if (q++ >= patend)
6102             break;
6103
6104         /* FLAGS */
6105
6106         while (*q) {
6107             switch (*q) {
6108             case ' ':
6109             case '+':
6110                 plus = *q++;
6111                 continue;
6112
6113             case '-':
6114                 left = TRUE;
6115                 q++;
6116                 continue;
6117
6118             case '0':
6119                 fill = *q++;
6120                 continue;
6121
6122             case '#':
6123                 alt = TRUE;
6124                 q++;
6125                 continue;
6126
6127             case '*':                   /* printf("%*vX",":",$ipv6addr) */
6128                 if (q[1] != 'v')
6129                     break;
6130                 q++;
6131                 if (args)
6132                     vecsv = va_arg(*args, SV*);
6133                 else if (svix < svmax)
6134                     vecsv = svargs[svix++];
6135                 else
6136                     continue;
6137                 dotstr = SvPVx(vecsv,dotstrlen);
6138                 if (DO_UTF8(vecsv))
6139                     is_utf = TRUE;
6140                 /* FALL THROUGH */
6141
6142             case 'v':
6143                 vectorize = TRUE;
6144                 q++;
6145                 continue;
6146
6147             default:
6148                 break;
6149             }
6150             break;
6151         }
6152
6153         /* WIDTH */
6154
6155     scanwidth:
6156
6157         if (*q == '*') {
6158             if (asterisk)
6159                 goto unknown;
6160             asterisk = TRUE;
6161             q++;
6162         }
6163
6164         switch (*q) {
6165         case '1': case '2': case '3':
6166         case '4': case '5': case '6':
6167         case '7': case '8': case '9':
6168             width = 0;
6169             while (isDIGIT(*q))
6170                 width = width * 10 + (*q++ - '0');
6171             if (*q == '$') {
6172                 if (asterisk && ewix == 0) {
6173                     ewix  = width;
6174                     width = 0;
6175                     q++;
6176                     goto scanwidth;
6177                 } else if (epix == 0) {
6178                     epix  = width;
6179                     width = 0;
6180                     q++;
6181                     goto scanwidth;
6182                 } else
6183                     goto unknown;
6184             }
6185         }
6186
6187         if (asterisk) {
6188             if (args)
6189                 i = va_arg(*args, int);
6190             else
6191                 i = (ewix ? ewix <= svmax : svix < svmax) ?
6192                     SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6193             left |= (i < 0);
6194             width = (i < 0) ? -i : i;
6195         }
6196
6197         /* PRECISION */
6198
6199         if (*q == '.') {
6200             q++;
6201             if (*q == '*') {
6202                 if (args)
6203                     i = va_arg(*args, int);
6204                 else
6205                     i = (ewix ? ewix <= svmax : svix < svmax)
6206                         ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6207                 precis = (i < 0) ? 0 : i;
6208                 q++;
6209             }
6210             else {
6211                 precis = 0;
6212                 while (isDIGIT(*q))
6213                     precis = precis * 10 + (*q++ - '0');
6214             }
6215             has_precis = TRUE;
6216         }
6217
6218         if (vectorize) {
6219             if (args) {
6220                 vecsv = va_arg(*args, SV*);
6221                 vecstr = (U8*)SvPVx(vecsv,veclen);
6222                 utf = DO_UTF8(vecsv);
6223             }
6224             else if (epix ? epix <= svmax : svix < svmax) {
6225                 vecsv = svargs[epix ? epix-1 : svix++];
6226                 vecstr = (U8*)SvPVx(vecsv,veclen);
6227                 utf = DO_UTF8(vecsv);
6228             }
6229             else {
6230                 vecstr = (U8*)"";
6231                 veclen = 0;
6232             }
6233         }
6234
6235         /* SIZE */
6236
6237         switch (*q) {
6238 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6239         case 'L':                       /* Ld */
6240             /* FALL THROUGH */
6241 #endif
6242 #ifdef HAS_QUAD
6243         case 'q':                       /* qd */
6244             intsize = 'q';
6245             q++;
6246             break;
6247 #endif
6248         case 'l':
6249 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6250              if (*(q + 1) == 'l') {     /* lld, llf */
6251                 intsize = 'q';
6252                 q += 2;
6253                 break;
6254              }
6255 #endif
6256             /* FALL THROUGH */
6257         case 'h':
6258             /* FALL THROUGH */
6259         case 'V':
6260             intsize = *q++;
6261             break;
6262         }
6263
6264         /* CONVERSION */
6265
6266         switch (c = *q++) {
6267
6268             /* STRINGS */
6269
6270         case '%':
6271             eptr = q - 1;
6272             elen = 1;
6273             goto string;
6274
6275         case 'c':
6276             if (args)
6277                 uv = va_arg(*args, int);
6278             else
6279                 uv = (epix ? epix <= svmax : svix < svmax) ?
6280                     SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6281             if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6282                 eptr = (char*)utf8buf;
6283                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6284                 is_utf = TRUE;
6285             }
6286             else {
6287                 c = (char)uv;
6288                 eptr = &c;
6289                 elen = 1;
6290             }
6291             goto string;
6292
6293         case 's':
6294             if (args) {
6295                 eptr = va_arg(*args, char*);
6296                 if (eptr)
6297 #ifdef MACOS_TRADITIONAL
6298                   /* On MacOS, %#s format is used for Pascal strings */
6299                   if (alt)
6300                     elen = *eptr++;
6301                   else
6302 #endif
6303                     elen = strlen(eptr);
6304                 else {
6305                     eptr = nullstr;
6306                     elen = sizeof nullstr - 1;
6307                 }
6308             }
6309             else if (epix ? epix <= svmax : svix < svmax) {
6310                 argsv = svargs[epix ? epix-1 : svix++];
6311                 eptr = SvPVx(argsv, elen);
6312                 if (DO_UTF8(argsv)) {
6313                     if (has_precis && precis < elen) {
6314                         I32 p = precis;
6315                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6316                         precis = p;
6317                     }
6318                     if (width) { /* fudge width (can't fudge elen) */
6319                         width += elen - sv_len_utf8(argsv);
6320                     }
6321                     is_utf = TRUE;
6322                 }
6323             }
6324             goto string;
6325
6326         case '_':
6327             /*
6328              * The "%_" hack might have to be changed someday,
6329              * if ISO or ANSI decide to use '_' for something.
6330              * So we keep it hidden from users' code.
6331              */
6332             if (!args)
6333                 goto unknown;
6334             argsv = va_arg(*args,SV*);
6335             eptr = SvPVx(argsv, elen);
6336             if (DO_UTF8(argsv))
6337                 is_utf = TRUE;
6338
6339         string:
6340             vectorize = FALSE;
6341             if (has_precis && elen > precis)
6342                 elen = precis;
6343             break;
6344
6345             /* INTEGERS */
6346
6347         case 'p':
6348             if (alt)
6349                 goto unknown;
6350             if (args)
6351                 uv = PTR2UV(va_arg(*args, void*));
6352             else
6353                 uv = (epix ? epix <= svmax : svix < svmax) ?
6354                     PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
6355             base = 16;
6356             goto integer;
6357
6358         case 'D':
6359 #ifdef IV_IS_QUAD
6360             intsize = 'q';
6361 #else
6362             intsize = 'l';
6363 #endif
6364             /* FALL THROUGH */
6365         case 'd':
6366         case 'i':
6367             if (vectorize) {
6368                 STRLEN ulen;
6369                 if (!veclen) {
6370                     vectorize = FALSE;
6371                     break;
6372                 }
6373                 if (utf)
6374                     iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
6375                 else {
6376                     iv = *vecstr;
6377                     ulen = 1;
6378                 }
6379                 vecstr += ulen;
6380                 veclen -= ulen;
6381             }
6382             else if (args) {
6383                 switch (intsize) {
6384                 case 'h':       iv = (short)va_arg(*args, int); break;
6385                 default:        iv = va_arg(*args, int); break;
6386                 case 'l':       iv = va_arg(*args, long); break;
6387                 case 'V':       iv = va_arg(*args, IV); break;
6388 #ifdef HAS_QUAD
6389                 case 'q':       iv = va_arg(*args, Quad_t); break;
6390 #endif
6391                 }
6392             }
6393             else {
6394                 iv = (epix ? epix <= svmax : svix < svmax) ?
6395                     SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6396                 switch (intsize) {
6397                 case 'h':       iv = (short)iv; break;
6398                 default:        break;
6399                 case 'l':       iv = (long)iv; break;
6400                 case 'V':       break;
6401 #ifdef HAS_QUAD
6402                 case 'q':       iv = (Quad_t)iv; break;
6403 #endif
6404                 }
6405             }
6406             if (iv >= 0) {
6407                 uv = iv;
6408                 if (plus)
6409                     esignbuf[esignlen++] = plus;
6410             }
6411             else {
6412                 uv = -iv;
6413                 esignbuf[esignlen++] = '-';
6414             }
6415             base = 10;
6416             goto integer;
6417
6418         case 'U':
6419 #ifdef IV_IS_QUAD
6420             intsize = 'q';
6421 #else
6422             intsize = 'l';
6423 #endif
6424             /* FALL THROUGH */
6425         case 'u':
6426             base = 10;
6427             goto uns_integer;
6428
6429         case 'b':
6430             base = 2;
6431             goto uns_integer;
6432
6433         case 'O':
6434 #ifdef IV_IS_QUAD
6435             intsize = 'q';
6436 #else
6437             intsize = 'l';
6438 #endif
6439             /* FALL THROUGH */
6440         case 'o':
6441             base = 8;
6442             goto uns_integer;
6443
6444         case 'X':
6445         case 'x':
6446             base = 16;
6447
6448         uns_integer:
6449             if (vectorize) {
6450                 STRLEN ulen;
6451         vector:
6452                 if (!veclen) {
6453                     vectorize = FALSE;
6454                     break;
6455                 }
6456                 if (utf)
6457                     uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
6458                 else {
6459                     uv = *vecstr;
6460                     ulen = 1;
6461                 }
6462                 vecstr += ulen;
6463                 veclen -= ulen;
6464             }
6465             else if (args) {
6466                 switch (intsize) {
6467                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
6468                 default:   uv = va_arg(*args, unsigned); break;
6469                 case 'l':  uv = va_arg(*args, unsigned long); break;
6470                 case 'V':  uv = va_arg(*args, UV); break;
6471 #ifdef HAS_QUAD
6472                 case 'q':  uv = va_arg(*args, Quad_t); break;
6473 #endif
6474                 }
6475             }
6476             else {
6477                 uv = (epix ? epix <= svmax : svix < svmax) ?
6478                     SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
6479                 switch (intsize) {
6480                 case 'h':       uv = (unsigned short)uv; break;
6481                 default:        break;
6482                 case 'l':       uv = (unsigned long)uv; break;
6483                 case 'V':       break;
6484 #ifdef HAS_QUAD
6485                 case 'q':       uv = (Quad_t)uv; break;
6486 #endif
6487                 }
6488             }
6489
6490         integer:
6491             eptr = ebuf + sizeof ebuf;
6492             switch (base) {
6493                 unsigned dig;
6494             case 16:
6495                 if (!uv)
6496                     alt = FALSE;
6497                 p = (char*)((c == 'X')
6498                             ? "0123456789ABCDEF" : "0123456789abcdef");
6499                 do {
6500                     dig = uv & 15;
6501                     *--eptr = p[dig];
6502                 } while (uv >>= 4);
6503                 if (alt) {
6504                     esignbuf[esignlen++] = '0';
6505                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
6506                 }
6507                 break;
6508             case 8:
6509                 do {
6510                     dig = uv & 7;
6511                     *--eptr = '0' + dig;
6512                 } while (uv >>= 3);
6513                 if (alt && *eptr != '0')
6514                     *--eptr = '0';
6515                 break;
6516             case 2:
6517                 do {
6518                     dig = uv & 1;
6519                     *--eptr = '0' + dig;
6520                 } while (uv >>= 1);
6521                 if (alt) {
6522                     esignbuf[esignlen++] = '0';
6523                     esignbuf[esignlen++] = 'b';
6524                 }
6525                 break;
6526             default:            /* it had better be ten or less */
6527 #if defined(PERL_Y2KWARN)
6528                 if (ckWARN(WARN_Y2K)) {
6529                     STRLEN n;
6530                     char *s = SvPV(sv,n);
6531                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6532                         && (n == 2 || !isDIGIT(s[n-3])))
6533                     {
6534                         Perl_warner(aTHX_ WARN_Y2K,
6535                                     "Possible Y2K bug: %%%c %s",
6536                                     c, "format string following '19'");
6537                     }
6538                 }
6539 #endif
6540                 do {
6541                     dig = uv % base;
6542                     *--eptr = '0' + dig;
6543                 } while (uv /= base);
6544                 break;
6545             }
6546             elen = (ebuf + sizeof ebuf) - eptr;
6547             if (has_precis) {
6548                 if (precis > elen)
6549                     zeros = precis - elen;
6550                 else if (precis == 0 && elen == 1 && *eptr == '0')
6551                     elen = 0;
6552             }
6553             break;
6554
6555             /* FLOATING POINT */
6556
6557         case 'F':
6558             c = 'f';            /* maybe %F isn't supported here */
6559             /* FALL THROUGH */
6560         case 'e': case 'E':
6561         case 'f':
6562         case 'g': case 'G':
6563
6564             /* This is evil, but floating point is even more evil */
6565
6566             vectorize = FALSE;
6567             if (args)
6568                 nv = va_arg(*args, NV);
6569             else
6570                 nv = (epix ? epix <= svmax : svix < svmax) ?
6571                     SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
6572
6573             need = 0;
6574             if (c != 'e' && c != 'E') {
6575                 i = PERL_INT_MIN;
6576                 (void)Perl_frexp(nv, &i);
6577                 if (i == PERL_INT_MIN)
6578                     Perl_die(aTHX_ "panic: frexp");
6579                 if (i > 0)
6580                     need = BIT_DIGITS(i);
6581             }
6582             need += has_precis ? precis : 6; /* known default */
6583             if (need < width)
6584                 need = width;
6585
6586             need += 20; /* fudge factor */
6587             if (PL_efloatsize < need) {
6588                 Safefree(PL_efloatbuf);
6589                 PL_efloatsize = need + 20; /* more fudge */
6590                 New(906, PL_efloatbuf, PL_efloatsize, char);
6591                 PL_efloatbuf[0] = '\0';
6592             }
6593
6594             eptr = ebuf + sizeof ebuf;
6595             *--eptr = '\0';
6596             *--eptr = c;
6597 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
6598             {
6599                 /* Copy the one or more characters in a long double
6600                  * format before the 'base' ([efgEFG]) character to
6601                  * the format string. */
6602                 static char const prifldbl[] = PERL_PRIfldbl;
6603                 char const *p = prifldbl + sizeof(prifldbl) - 3;
6604                 while (p >= prifldbl) { *--eptr = *p--; }
6605             }
6606 #endif
6607             if (has_precis) {
6608                 base = precis;
6609                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6610                 *--eptr = '.';
6611             }
6612             if (width) {
6613                 base = width;
6614                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6615             }
6616             if (fill == '0')
6617                 *--eptr = fill;
6618             if (left)
6619                 *--eptr = '-';
6620             if (plus)
6621                 *--eptr = plus;
6622             if (alt)
6623                 *--eptr = '#';
6624             *--eptr = '%';
6625
6626             (void)sprintf(PL_efloatbuf, eptr, nv);
6627 #ifdef USE_LOCALE_NUMERIC
6628             if ((PL_hints & HINT_LOCALE) && maybe_tainted)
6629                 *maybe_tainted = TRUE;
6630 #endif
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         case SAVEt_PADSV:
7666             longval = (long)POPLONG(ss,ix);
7667             TOPLONG(nss,ix) = longval;
7668             ptr = POPPTR(ss,ix);
7669             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7670             sv = (SV*)POPPTR(ss,ix);
7671             TOPPTR(nss,ix) = sv_dup(sv);
7672             break;
7673         default:
7674             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7675         }
7676     }
7677
7678     return nss;
7679 }
7680
7681 #ifdef PERL_OBJECT
7682 #include "XSUB.h"
7683 #endif
7684
7685 PerlInterpreter *
7686 perl_clone(PerlInterpreter *proto_perl, UV flags)
7687 {
7688 #ifdef PERL_OBJECT
7689     CPerlObj *pPerl = (CPerlObj*)proto_perl;
7690 #endif
7691
7692 #ifdef PERL_IMPLICIT_SYS
7693     return perl_clone_using(proto_perl, flags,
7694                             proto_perl->IMem,
7695                             proto_perl->IMemShared,
7696                             proto_perl->IMemParse,
7697                             proto_perl->IEnv,
7698                             proto_perl->IStdIO,
7699                             proto_perl->ILIO,
7700                             proto_perl->IDir,
7701                             proto_perl->ISock,
7702                             proto_perl->IProc);
7703 }
7704
7705 PerlInterpreter *
7706 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7707                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
7708                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7709                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7710                  struct IPerlDir* ipD, struct IPerlSock* ipS,
7711                  struct IPerlProc* ipP)
7712 {
7713     /* XXX many of the string copies here can be optimized if they're
7714      * constants; they need to be allocated as common memory and just
7715      * their pointers copied. */
7716
7717     IV i;
7718 #  ifdef PERL_OBJECT
7719     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7720                                         ipD, ipS, ipP);
7721     PERL_SET_THX(pPerl);
7722 #  else         /* !PERL_OBJECT */
7723     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7724     PERL_SET_THX(my_perl);
7725
7726 #    ifdef DEBUGGING
7727     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7728     PL_markstack = 0;
7729     PL_scopestack = 0;
7730     PL_savestack = 0;
7731     PL_retstack = 0;
7732 #    else       /* !DEBUGGING */
7733     Zero(my_perl, 1, PerlInterpreter);
7734 #    endif      /* DEBUGGING */
7735
7736     /* host pointers */
7737     PL_Mem              = ipM;
7738     PL_MemShared        = ipMS;
7739     PL_MemParse         = ipMP;
7740     PL_Env              = ipE;
7741     PL_StdIO            = ipStd;
7742     PL_LIO              = ipLIO;
7743     PL_Dir              = ipD;
7744     PL_Sock             = ipS;
7745     PL_Proc             = ipP;
7746 #  endif        /* PERL_OBJECT */
7747 #else           /* !PERL_IMPLICIT_SYS */
7748     IV i;
7749     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7750     PERL_SET_THX(my_perl);
7751
7752 #    ifdef DEBUGGING
7753     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7754     PL_markstack = 0;
7755     PL_scopestack = 0;
7756     PL_savestack = 0;
7757     PL_retstack = 0;
7758 #    else       /* !DEBUGGING */
7759     Zero(my_perl, 1, PerlInterpreter);
7760 #    endif      /* DEBUGGING */
7761 #endif          /* PERL_IMPLICIT_SYS */
7762
7763     /* arena roots */
7764     PL_xiv_arenaroot    = NULL;
7765     PL_xiv_root         = NULL;
7766     PL_xnv_arenaroot    = NULL;
7767     PL_xnv_root         = NULL;
7768     PL_xrv_arenaroot    = NULL;
7769     PL_xrv_root         = NULL;
7770     PL_xpv_arenaroot    = NULL;
7771     PL_xpv_root         = NULL;
7772     PL_xpviv_arenaroot  = NULL;
7773     PL_xpviv_root       = NULL;
7774     PL_xpvnv_arenaroot  = NULL;
7775     PL_xpvnv_root       = NULL;
7776     PL_xpvcv_arenaroot  = NULL;
7777     PL_xpvcv_root       = NULL;
7778     PL_xpvav_arenaroot  = NULL;
7779     PL_xpvav_root       = NULL;
7780     PL_xpvhv_arenaroot  = NULL;
7781     PL_xpvhv_root       = NULL;
7782     PL_xpvmg_arenaroot  = NULL;
7783     PL_xpvmg_root       = NULL;
7784     PL_xpvlv_arenaroot  = NULL;
7785     PL_xpvlv_root       = NULL;
7786     PL_xpvbm_arenaroot  = NULL;
7787     PL_xpvbm_root       = NULL;
7788     PL_he_arenaroot     = NULL;
7789     PL_he_root          = NULL;
7790     PL_nice_chunk       = NULL;
7791     PL_nice_chunk_size  = 0;
7792     PL_sv_count         = 0;
7793     PL_sv_objcount      = 0;
7794     PL_sv_root          = Nullsv;
7795     PL_sv_arenaroot     = Nullsv;
7796
7797     PL_debug            = proto_perl->Idebug;
7798
7799     /* create SV map for pointer relocation */
7800     PL_ptr_table = ptr_table_new();
7801
7802     /* initialize these special pointers as early as possible */
7803     SvANY(&PL_sv_undef)         = NULL;
7804     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
7805     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
7806     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7807
7808 #ifdef PERL_OBJECT
7809     SvUPGRADE(&PL_sv_no, SVt_PVNV);
7810 #else
7811     SvANY(&PL_sv_no)            = new_XPVNV();
7812 #endif
7813     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
7814     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7815     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
7816     SvCUR(&PL_sv_no)            = 0;
7817     SvLEN(&PL_sv_no)            = 1;
7818     SvNVX(&PL_sv_no)            = 0;
7819     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7820
7821 #ifdef PERL_OBJECT
7822     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7823 #else
7824     SvANY(&PL_sv_yes)           = new_XPVNV();
7825 #endif
7826     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
7827     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7828     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
7829     SvCUR(&PL_sv_yes)           = 1;
7830     SvLEN(&PL_sv_yes)           = 2;
7831     SvNVX(&PL_sv_yes)           = 1;
7832     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7833
7834     /* create shared string table */
7835     PL_strtab           = newHV();
7836     HvSHAREKEYS_off(PL_strtab);
7837     hv_ksplit(PL_strtab, 512);
7838     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7839
7840     PL_compiling                = proto_perl->Icompiling;
7841     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
7842     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
7843     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7844     if (!specialWARN(PL_compiling.cop_warnings))
7845         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7846     if (!specialCopIO(PL_compiling.cop_io))
7847         PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
7848     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7849
7850     /* pseudo environmental stuff */
7851     PL_origargc         = proto_perl->Iorigargc;
7852     i = PL_origargc;
7853     New(0, PL_origargv, i+1, char*);
7854     PL_origargv[i] = '\0';
7855     while (i-- > 0) {
7856         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
7857     }
7858     PL_envgv            = gv_dup(proto_perl->Ienvgv);
7859     PL_incgv            = gv_dup(proto_perl->Iincgv);
7860     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
7861     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
7862     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
7863     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
7864
7865     /* switches */
7866     PL_minus_c          = proto_perl->Iminus_c;
7867     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
7868     PL_localpatches     = proto_perl->Ilocalpatches;
7869     PL_splitstr         = proto_perl->Isplitstr;
7870     PL_preprocess       = proto_perl->Ipreprocess;
7871     PL_minus_n          = proto_perl->Iminus_n;
7872     PL_minus_p          = proto_perl->Iminus_p;
7873     PL_minus_l          = proto_perl->Iminus_l;
7874     PL_minus_a          = proto_perl->Iminus_a;
7875     PL_minus_F          = proto_perl->Iminus_F;
7876     PL_doswitches       = proto_perl->Idoswitches;
7877     PL_dowarn           = proto_perl->Idowarn;
7878     PL_doextract        = proto_perl->Idoextract;
7879     PL_sawampersand     = proto_perl->Isawampersand;
7880     PL_unsafe           = proto_perl->Iunsafe;
7881     PL_inplace          = SAVEPV(proto_perl->Iinplace);
7882     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
7883     PL_perldb           = proto_perl->Iperldb;
7884     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7885
7886     /* magical thingies */
7887     /* XXX time(&PL_basetime) when asked for? */
7888     PL_basetime         = proto_perl->Ibasetime;
7889     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
7890
7891     PL_maxsysfd         = proto_perl->Imaxsysfd;
7892     PL_multiline        = proto_perl->Imultiline;
7893     PL_statusvalue      = proto_perl->Istatusvalue;
7894 #ifdef VMS
7895     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
7896 #endif
7897
7898     /* shortcuts to various I/O objects */
7899     PL_stdingv          = gv_dup(proto_perl->Istdingv);
7900     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
7901     PL_defgv            = gv_dup(proto_perl->Idefgv);
7902     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
7903     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
7904     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
7905
7906     /* shortcuts to regexp stuff */
7907     PL_replgv           = gv_dup(proto_perl->Ireplgv);
7908
7909     /* shortcuts to misc objects */
7910     PL_errgv            = gv_dup(proto_perl->Ierrgv);
7911
7912     /* shortcuts to debugging objects */
7913     PL_DBgv             = gv_dup(proto_perl->IDBgv);
7914     PL_DBline           = gv_dup(proto_perl->IDBline);
7915     PL_DBsub            = gv_dup(proto_perl->IDBsub);
7916     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
7917     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
7918     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
7919     PL_lineary          = av_dup(proto_perl->Ilineary);
7920     PL_dbargs           = av_dup(proto_perl->Idbargs);
7921
7922     /* symbol tables */
7923     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
7924     PL_curstash         = hv_dup(proto_perl->Tcurstash);
7925     PL_debstash         = hv_dup(proto_perl->Idebstash);
7926     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
7927     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
7928
7929     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
7930     PL_endav            = av_dup_inc(proto_perl->Iendav);
7931     PL_checkav          = av_dup_inc(proto_perl->Icheckav);
7932     PL_initav           = av_dup_inc(proto_perl->Iinitav);
7933
7934     PL_sub_generation   = proto_perl->Isub_generation;
7935
7936     /* funky return mechanisms */
7937     PL_forkprocess      = proto_perl->Iforkprocess;
7938
7939     /* subprocess state */
7940     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
7941
7942     /* internal state */
7943     PL_tainting         = proto_perl->Itainting;
7944     PL_maxo             = proto_perl->Imaxo;
7945     if (proto_perl->Iop_mask)
7946         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7947     else
7948         PL_op_mask      = Nullch;
7949
7950     /* current interpreter roots */
7951     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
7952     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
7953     PL_main_start       = proto_perl->Imain_start;
7954     PL_eval_root        = proto_perl->Ieval_root;
7955     PL_eval_start       = proto_perl->Ieval_start;
7956
7957     /* runtime control stuff */
7958     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7959     PL_copline          = proto_perl->Icopline;
7960
7961     PL_filemode         = proto_perl->Ifilemode;
7962     PL_lastfd           = proto_perl->Ilastfd;
7963     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
7964     PL_Argv             = NULL;
7965     PL_Cmd              = Nullch;
7966     PL_gensym           = proto_perl->Igensym;
7967     PL_preambled        = proto_perl->Ipreambled;
7968     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
7969     PL_laststatval      = proto_perl->Ilaststatval;
7970     PL_laststype        = proto_perl->Ilaststype;
7971     PL_mess_sv          = Nullsv;
7972
7973     PL_orslen           = proto_perl->Iorslen;
7974     PL_ors              = SAVEPVN(proto_perl->Iors, PL_orslen);
7975     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
7976
7977     /* interpreter atexit processing */
7978     PL_exitlistlen      = proto_perl->Iexitlistlen;
7979     if (PL_exitlistlen) {
7980         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7981         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7982     }
7983     else
7984         PL_exitlist     = (PerlExitListEntry*)NULL;
7985     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
7986
7987     PL_profiledata      = NULL;
7988     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
7989     /* PL_rsfp_filters entries have fake IoDIRP() */
7990     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
7991
7992     PL_compcv                   = cv_dup(proto_perl->Icompcv);
7993     PL_comppad                  = av_dup(proto_perl->Icomppad);
7994     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
7995     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
7996     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
7997     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
7998                                                         proto_perl->Tcurpad);
7999
8000 #ifdef HAVE_INTERP_INTERN
8001     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8002 #endif
8003
8004     /* more statics moved here */
8005     PL_generation       = proto_perl->Igeneration;
8006     PL_DBcv             = cv_dup(proto_perl->IDBcv);
8007
8008     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
8009     PL_in_clean_all     = proto_perl->Iin_clean_all;
8010
8011     PL_uid              = proto_perl->Iuid;
8012     PL_euid             = proto_perl->Ieuid;
8013     PL_gid              = proto_perl->Igid;
8014     PL_egid             = proto_perl->Iegid;
8015     PL_nomemok          = proto_perl->Inomemok;
8016     PL_an               = proto_perl->Ian;
8017     PL_cop_seqmax       = proto_perl->Icop_seqmax;
8018     PL_op_seqmax        = proto_perl->Iop_seqmax;
8019     PL_evalseq          = proto_perl->Ievalseq;
8020     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
8021     PL_origalen         = proto_perl->Iorigalen;
8022     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
8023     PL_osname           = SAVEPV(proto_perl->Iosname);
8024     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
8025     PL_sighandlerp      = proto_perl->Isighandlerp;
8026
8027
8028     PL_runops           = proto_perl->Irunops;
8029
8030     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8031
8032 #ifdef CSH
8033     PL_cshlen           = proto_perl->Icshlen;
8034     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8035 #endif
8036
8037     PL_lex_state        = proto_perl->Ilex_state;
8038     PL_lex_defer        = proto_perl->Ilex_defer;
8039     PL_lex_expect       = proto_perl->Ilex_expect;
8040     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
8041     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
8042     PL_lex_starts       = proto_perl->Ilex_starts;
8043     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
8044     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
8045     PL_lex_op           = proto_perl->Ilex_op;
8046     PL_lex_inpat        = proto_perl->Ilex_inpat;
8047     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
8048     PL_lex_brackets     = proto_perl->Ilex_brackets;
8049     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8050     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
8051     PL_lex_casemods     = proto_perl->Ilex_casemods;
8052     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8053     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
8054
8055     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8056     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8057     PL_nexttoke         = proto_perl->Inexttoke;
8058
8059     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
8060     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8061     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8062     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8063     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8064     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8065     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8066     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8067     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8068     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8069     PL_pending_ident    = proto_perl->Ipending_ident;
8070     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
8071
8072     PL_expect           = proto_perl->Iexpect;
8073
8074     PL_multi_start      = proto_perl->Imulti_start;
8075     PL_multi_end        = proto_perl->Imulti_end;
8076     PL_multi_open       = proto_perl->Imulti_open;
8077     PL_multi_close      = proto_perl->Imulti_close;
8078
8079     PL_error_count      = proto_perl->Ierror_count;
8080     PL_subline          = proto_perl->Isubline;
8081     PL_subname          = sv_dup_inc(proto_perl->Isubname);
8082
8083     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
8084     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
8085     PL_padix                    = proto_perl->Ipadix;
8086     PL_padix_floor              = proto_perl->Ipadix_floor;
8087     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
8088
8089     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8090     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8091     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8092     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8093     PL_last_lop_op      = proto_perl->Ilast_lop_op;
8094     PL_in_my            = proto_perl->Iin_my;
8095     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
8096 #ifdef FCRYPT
8097     PL_cryptseen        = proto_perl->Icryptseen;
8098 #endif
8099
8100     PL_hints            = proto_perl->Ihints;
8101
8102     PL_amagic_generation        = proto_perl->Iamagic_generation;
8103
8104 #ifdef USE_LOCALE_COLLATE
8105     PL_collation_ix     = proto_perl->Icollation_ix;
8106     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
8107     PL_collation_standard       = proto_perl->Icollation_standard;
8108     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
8109     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
8110 #endif /* USE_LOCALE_COLLATE */
8111
8112 #ifdef USE_LOCALE_NUMERIC
8113     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
8114     PL_numeric_standard = proto_perl->Inumeric_standard;
8115     PL_numeric_local    = proto_perl->Inumeric_local;
8116     PL_numeric_radix    = proto_perl->Inumeric_radix;
8117 #endif /* !USE_LOCALE_NUMERIC */
8118
8119     /* utf8 character classes */
8120     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
8121     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
8122     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
8123     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
8124     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
8125     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
8126     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
8127     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
8128     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
8129     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
8130     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
8131     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
8132     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
8133     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
8134     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
8135     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
8136     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
8137
8138     /* swatch cache */
8139     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
8140     PL_last_swash_klen  = 0;
8141     PL_last_swash_key[0]= '\0';
8142     PL_last_swash_tmps  = (U8*)NULL;
8143     PL_last_swash_slen  = 0;
8144
8145     /* perly.c globals */
8146     PL_yydebug          = proto_perl->Iyydebug;
8147     PL_yynerrs          = proto_perl->Iyynerrs;
8148     PL_yyerrflag        = proto_perl->Iyyerrflag;
8149     PL_yychar           = proto_perl->Iyychar;
8150     PL_yyval            = proto_perl->Iyyval;
8151     PL_yylval           = proto_perl->Iyylval;
8152
8153     PL_glob_index       = proto_perl->Iglob_index;
8154     PL_srand_called     = proto_perl->Isrand_called;
8155     PL_uudmap['M']      = 0;            /* reinits on demand */
8156     PL_bitcount         = Nullch;       /* reinits on demand */
8157
8158     if (proto_perl->Ipsig_ptr) {
8159         int sig_num[] = { SIG_NUM };
8160         Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8161         Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8162         for (i = 1; PL_sig_name[i]; i++) {
8163             PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8164             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8165         }
8166     }
8167     else {
8168         PL_psig_ptr     = (SV**)NULL;
8169         PL_psig_name    = (SV**)NULL;
8170     }
8171
8172     /* thrdvar.h stuff */
8173
8174     if (flags & 1) {
8175         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8176         PL_tmps_ix              = proto_perl->Ttmps_ix;
8177         PL_tmps_max             = proto_perl->Ttmps_max;
8178         PL_tmps_floor           = proto_perl->Ttmps_floor;
8179         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8180         i = 0;
8181         while (i <= PL_tmps_ix) {
8182             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8183             ++i;
8184         }
8185
8186         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8187         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8188         Newz(54, PL_markstack, i, I32);
8189         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
8190                                                   - proto_perl->Tmarkstack);
8191         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
8192                                                   - proto_perl->Tmarkstack);
8193         Copy(proto_perl->Tmarkstack, PL_markstack,
8194              PL_markstack_ptr - PL_markstack + 1, I32);
8195
8196         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8197          * NOTE: unlike the others! */
8198         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
8199         PL_scopestack_max       = proto_perl->Tscopestack_max;
8200         Newz(54, PL_scopestack, PL_scopestack_max, I32);
8201         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8202
8203         /* next push_return() sets PL_retstack[PL_retstack_ix]
8204          * NOTE: unlike the others! */
8205         PL_retstack_ix          = proto_perl->Tretstack_ix;
8206         PL_retstack_max         = proto_perl->Tretstack_max;
8207         Newz(54, PL_retstack, PL_retstack_max, OP*);
8208         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8209
8210         /* NOTE: si_dup() looks at PL_markstack */
8211         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
8212
8213         /* PL_curstack          = PL_curstackinfo->si_stack; */
8214         PL_curstack             = av_dup(proto_perl->Tcurstack);
8215         PL_mainstack            = av_dup(proto_perl->Tmainstack);
8216
8217         /* next PUSHs() etc. set *(PL_stack_sp+1) */
8218         PL_stack_base           = AvARRAY(PL_curstack);
8219         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
8220                                                    - proto_perl->Tstack_base);
8221         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
8222
8223         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8224          * NOTE: unlike the others! */
8225         PL_savestack_ix         = proto_perl->Tsavestack_ix;
8226         PL_savestack_max        = proto_perl->Tsavestack_max;
8227         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8228         PL_savestack            = ss_dup(proto_perl);
8229     }
8230     else {
8231         init_stacks();
8232         ENTER;                  /* perl_destruct() wants to LEAVE; */
8233     }
8234
8235     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
8236     PL_top_env          = &PL_start_env;
8237
8238     PL_op               = proto_perl->Top;
8239
8240     PL_Sv               = Nullsv;
8241     PL_Xpv              = (XPV*)NULL;
8242     PL_na               = proto_perl->Tna;
8243
8244     PL_statbuf          = proto_perl->Tstatbuf;
8245     PL_statcache        = proto_perl->Tstatcache;
8246     PL_statgv           = gv_dup(proto_perl->Tstatgv);
8247     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
8248 #ifdef HAS_TIMES
8249     PL_timesbuf         = proto_perl->Ttimesbuf;
8250 #endif
8251
8252     PL_tainted          = proto_perl->Ttainted;
8253     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
8254     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
8255     PL_rs               = sv_dup_inc(proto_perl->Trs);
8256     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
8257     PL_ofslen           = proto_perl->Tofslen;
8258     PL_ofs              = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8259     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
8260     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
8261     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
8262     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
8263     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
8264
8265     PL_restartop        = proto_perl->Trestartop;
8266     PL_in_eval          = proto_perl->Tin_eval;
8267     PL_delaymagic       = proto_perl->Tdelaymagic;
8268     PL_dirty            = proto_perl->Tdirty;
8269     PL_localizing       = proto_perl->Tlocalizing;
8270
8271 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8272     PL_protect          = proto_perl->Tprotect;
8273 #endif
8274     PL_errors           = sv_dup_inc(proto_perl->Terrors);
8275     PL_av_fetch_sv      = Nullsv;
8276     PL_hv_fetch_sv      = Nullsv;
8277     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
8278     PL_modcount         = proto_perl->Tmodcount;
8279     PL_lastgotoprobe    = Nullop;
8280     PL_dumpindent       = proto_perl->Tdumpindent;
8281
8282     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8283     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
8284     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
8285     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
8286     PL_sortcxix         = proto_perl->Tsortcxix;
8287     PL_efloatbuf        = Nullch;               /* reinits on demand */
8288     PL_efloatsize       = 0;                    /* reinits on demand */
8289
8290     /* regex stuff */
8291
8292     PL_screamfirst      = NULL;
8293     PL_screamnext       = NULL;
8294     PL_maxscream        = -1;                   /* reinits on demand */
8295     PL_lastscream       = Nullsv;
8296
8297     PL_watchaddr        = NULL;
8298     PL_watchok          = Nullch;
8299
8300     PL_regdummy         = proto_perl->Tregdummy;
8301     PL_regcomp_parse    = Nullch;
8302     PL_regxend          = Nullch;
8303     PL_regcode          = (regnode*)NULL;
8304     PL_regnaughty       = 0;
8305     PL_regsawback       = 0;
8306     PL_regprecomp       = Nullch;
8307     PL_regnpar          = 0;
8308     PL_regsize          = 0;
8309     PL_regflags         = 0;
8310     PL_regseen          = 0;
8311     PL_seen_zerolen     = 0;
8312     PL_seen_evals       = 0;
8313     PL_regcomp_rx       = (regexp*)NULL;
8314     PL_extralen         = 0;
8315     PL_colorset         = 0;            /* reinits PL_colors[] */
8316     /*PL_colors[6]      = {0,0,0,0,0,0};*/
8317     PL_reg_whilem_seen  = 0;
8318     PL_reginput         = Nullch;
8319     PL_regbol           = Nullch;
8320     PL_regeol           = Nullch;
8321     PL_regstartp        = (I32*)NULL;
8322     PL_regendp          = (I32*)NULL;
8323     PL_reglastparen     = (U32*)NULL;
8324     PL_regtill          = Nullch;
8325     PL_regprev          = '\n';
8326     PL_reg_start_tmp    = (char**)NULL;
8327     PL_reg_start_tmpl   = 0;
8328     PL_regdata          = (struct reg_data*)NULL;
8329     PL_bostr            = Nullch;
8330     PL_reg_flags        = 0;
8331     PL_reg_eval_set     = 0;
8332     PL_regnarrate       = 0;
8333     PL_regprogram       = (regnode*)NULL;
8334     PL_regindent        = 0;
8335     PL_regcc            = (CURCUR*)NULL;
8336     PL_reg_call_cc      = (struct re_cc_state*)NULL;
8337     PL_reg_re           = (regexp*)NULL;
8338     PL_reg_ganch        = Nullch;
8339     PL_reg_sv           = Nullsv;
8340     PL_reg_magic        = (MAGIC*)NULL;
8341     PL_reg_oldpos       = 0;
8342     PL_reg_oldcurpm     = (PMOP*)NULL;
8343     PL_reg_curpm        = (PMOP*)NULL;
8344     PL_reg_oldsaved     = Nullch;
8345     PL_reg_oldsavedlen  = 0;
8346     PL_reg_maxiter      = 0;
8347     PL_reg_leftiter     = 0;
8348     PL_reg_poscache     = Nullch;
8349     PL_reg_poscache_size= 0;
8350
8351     /* RE engine - function pointers */
8352     PL_regcompp         = proto_perl->Tregcompp;
8353     PL_regexecp         = proto_perl->Tregexecp;
8354     PL_regint_start     = proto_perl->Tregint_start;
8355     PL_regint_string    = proto_perl->Tregint_string;
8356     PL_regfree          = proto_perl->Tregfree;
8357
8358     PL_reginterp_cnt    = 0;
8359     PL_reg_starttry     = 0;
8360
8361 #ifdef PERL_OBJECT
8362     return (PerlInterpreter*)pPerl;
8363 #else
8364     return my_perl;
8365 #endif
8366 }
8367
8368 #else   /* !USE_ITHREADS */
8369
8370 #ifdef PERL_OBJECT
8371 #include "XSUB.h"
8372 #endif
8373
8374 #endif /* USE_ITHREADS */
8375
8376 static void
8377 do_report_used(pTHXo_ SV *sv)
8378 {
8379     if (SvTYPE(sv) != SVTYPEMASK) {
8380         PerlIO_printf(Perl_debug_log, "****\n");
8381         sv_dump(sv);
8382     }
8383 }
8384
8385 static void
8386 do_clean_objs(pTHXo_ SV *sv)
8387 {
8388     SV* rv;
8389
8390     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8391         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8392         if (SvWEAKREF(sv)) {
8393             sv_del_backref(sv);
8394             SvWEAKREF_off(sv);
8395             SvRV(sv) = 0;
8396         } else {
8397             SvROK_off(sv);
8398             SvRV(sv) = 0;
8399             SvREFCNT_dec(rv);
8400         }
8401     }
8402
8403     /* XXX Might want to check arrays, etc. */
8404 }
8405
8406 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8407 static void
8408 do_clean_named_objs(pTHXo_ SV *sv)
8409 {
8410     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8411         if ( SvOBJECT(GvSV(sv)) ||
8412              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8413              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8414              (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8415              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8416         {
8417             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8418             SvREFCNT_dec(sv);
8419         }
8420     }
8421 }
8422 #endif
8423
8424 static void
8425 do_clean_all(pTHXo_ SV *sv)
8426 {
8427     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8428     SvFLAGS(sv) |= SVf_BREAK;
8429     SvREFCNT_dec(sv);
8430 }
8431