sv.c

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