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