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