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                                                        (CV*)sref));
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                 if (args)
5967                     vecsv = va_arg(*args, SV*);
5968                 else if (svix < svmax)
5969                     vecsv = svargs[svix++];
5970                 else {
5971                     vecstr = (U8*)"";
5972                     veclen = 0;
5973                     continue;
5974                 }
5975                 vecstr = (U8*)SvPVx(vecsv,veclen);
5976                 utf = DO_UTF8(vecsv);
5977                 continue;
5978
5979             default:
5980                 break;
5981             }
5982             break;
5983         }
5984
5985         /* WIDTH */
5986
5987         switch (*q) {
5988         case '1': case '2': case '3':
5989         case '4': case '5': case '6':
5990         case '7': case '8': case '9':
5991             width = 0;
5992             while (isDIGIT(*q))
5993                 width = width * 10 + (*q++ - '0');
5994             break;
5995
5996         case '*':
5997             if (args)
5998                 i = va_arg(*args, int);
5999             else
6000                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6001             left |= (i < 0);
6002             width = (i < 0) ? -i : i;
6003             q++;
6004             break;
6005         }
6006
6007         /* PRECISION */
6008
6009         if (*q == '.') {
6010             q++;
6011             if (*q == '*') {
6012                 if (args)
6013                     i = va_arg(*args, int);
6014                 else
6015                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6016                 precis = (i < 0) ? 0 : i;
6017                 q++;
6018             }
6019             else {
6020                 precis = 0;
6021                 while (isDIGIT(*q))
6022                     precis = precis * 10 + (*q++ - '0');
6023             }
6024             has_precis = TRUE;
6025         }
6026
6027         /* SIZE */
6028
6029         switch (*q) {
6030 #ifdef HAS_QUAD
6031         case 'L':                       /* Ld */
6032         case 'q':                       /* qd */
6033             intsize = 'q';
6034             q++;
6035             break;
6036 #endif
6037         case 'l':
6038 #ifdef HAS_QUAD
6039              if (*(q + 1) == 'l') {     /* lld */
6040                 intsize = 'q';
6041                 q += 2;
6042                 break;
6043              }
6044 #endif
6045             /* FALL THROUGH */
6046         case 'h':
6047             /* FALL THROUGH */
6048         case 'V':
6049             intsize = *q++;
6050             break;
6051         }
6052
6053         /* CONVERSION */
6054
6055         switch (c = *q++) {
6056
6057             /* STRINGS */
6058
6059         case '%':
6060             eptr = q - 1;
6061             elen = 1;
6062             goto string;
6063
6064         case 'c':
6065             if (args)
6066                 uv = va_arg(*args, int);
6067             else
6068                 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6069             if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6070                 eptr = (char*)utf8buf;
6071                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6072                 is_utf = TRUE;
6073             }
6074             else {
6075                 c = (char)uv;
6076                 eptr = &c;
6077                 elen = 1;
6078             }
6079             goto string;
6080
6081         case 's':
6082             if (args) {
6083                 eptr = va_arg(*args, char*);
6084                 if (eptr)
6085 #ifdef MACOS_TRADITIONAL
6086                   /* On MacOS, %#s format is used for Pascal strings */
6087                   if (alt)
6088                     elen = *eptr++;
6089                   else
6090 #endif
6091                     elen = strlen(eptr);
6092                 else {
6093                     eptr = nullstr;
6094                     elen = sizeof nullstr - 1;
6095                 }
6096             }
6097             else if (svix < svmax) {
6098                 argsv = svargs[svix++];
6099                 eptr = SvPVx(argsv, elen);
6100                 if (DO_UTF8(argsv)) {
6101                     if (has_precis && precis < elen) {
6102                         I32 p = precis;
6103                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6104                         precis = p;
6105                     }
6106                     if (width) { /* fudge width (can't fudge elen) */
6107                         width += elen - sv_len_utf8(argsv);
6108                     }
6109                     is_utf = TRUE;
6110                 }
6111             }
6112             goto string;
6113
6114         case '_':
6115             /*
6116              * The "%_" hack might have to be changed someday,
6117              * if ISO or ANSI decide to use '_' for something.
6118              * So we keep it hidden from users' code.
6119              */
6120             if (!args)
6121                 goto unknown;
6122             argsv = va_arg(*args,SV*);
6123             eptr = SvPVx(argsv, elen);
6124             if (DO_UTF8(argsv))
6125                 is_utf = TRUE;
6126
6127         string:
6128             vectorize = FALSE;
6129             if (has_precis && elen > precis)
6130                 elen = precis;
6131             break;
6132
6133             /* INTEGERS */
6134
6135         case 'p':
6136             if (alt)
6137                 goto unknown;
6138             if (args)
6139                 uv = PTR2UV(va_arg(*args, void*));
6140             else
6141                 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6142             base = 16;
6143             goto integer;
6144
6145         case 'D':
6146 #ifdef IV_IS_QUAD
6147             intsize = 'q';
6148 #else
6149             intsize = 'l';
6150 #endif
6151             /* FALL THROUGH */
6152         case 'd':
6153         case 'i':
6154             if (vectorize) {
6155                 I32 ulen;
6156                 if (!veclen) {
6157                     vectorize = FALSE;
6158                     break;
6159                 }
6160                 if (utf)
6161                     iv = (IV)utf8_to_uv(vecstr, &ulen);
6162                 else {
6163                     iv = *vecstr;
6164                     ulen = 1;
6165                 }
6166                 vecstr += ulen;
6167                 veclen -= ulen;
6168             }
6169             else if (args) {
6170                 switch (intsize) {
6171                 case 'h':       iv = (short)va_arg(*args, int); break;
6172                 default:        iv = va_arg(*args, int); break;
6173                 case 'l':       iv = va_arg(*args, long); break;
6174                 case 'V':       iv = va_arg(*args, IV); break;
6175 #ifdef HAS_QUAD
6176                 case 'q':       iv = va_arg(*args, Quad_t); break;
6177 #endif
6178                 }
6179             }
6180             else {
6181                 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6182                 switch (intsize) {
6183                 case 'h':       iv = (short)iv; break;
6184                 default:        break;
6185                 case 'l':       iv = (long)iv; break;
6186                 case 'V':       break;
6187 #ifdef HAS_QUAD
6188                 case 'q':       iv = (Quad_t)iv; break;
6189 #endif
6190                 }
6191             }
6192             if (iv >= 0) {
6193                 uv = iv;
6194                 if (plus)
6195                     esignbuf[esignlen++] = plus;
6196             }
6197             else {
6198                 uv = -iv;
6199                 esignbuf[esignlen++] = '-';
6200             }
6201             base = 10;
6202             goto integer;
6203
6204         case 'U':
6205 #ifdef IV_IS_QUAD
6206             intsize = 'q';
6207 #else
6208             intsize = 'l';
6209 #endif
6210             /* FALL THROUGH */
6211         case 'u':
6212             base = 10;
6213             goto uns_integer;
6214
6215         case 'b':
6216             base = 2;
6217             goto uns_integer;
6218
6219         case 'O':
6220 #ifdef IV_IS_QUAD
6221             intsize = 'q';
6222 #else
6223             intsize = 'l';
6224 #endif
6225             /* FALL THROUGH */
6226         case 'o':
6227             base = 8;
6228             goto uns_integer;
6229
6230         case 'X':
6231         case 'x':
6232             base = 16;
6233
6234         uns_integer:
6235             if (vectorize) {
6236                 I32 ulen;
6237         vector:
6238                 if (!veclen) {
6239                     vectorize = FALSE;
6240                     break;
6241                 }
6242                 if (utf)
6243                     uv = utf8_to_uv(vecstr, &ulen);
6244                 else {
6245                     uv = *vecstr;
6246                     ulen = 1;
6247                 }
6248                 vecstr += ulen;
6249                 veclen -= ulen;
6250             }
6251             else if (args) {
6252                 switch (intsize) {
6253                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
6254                 default:   uv = va_arg(*args, unsigned); break;
6255                 case 'l':  uv = va_arg(*args, unsigned long); break;
6256                 case 'V':  uv = va_arg(*args, UV); break;
6257 #ifdef HAS_QUAD
6258                 case 'q':  uv = va_arg(*args, Quad_t); break;
6259 #endif
6260                 }
6261             }
6262             else {
6263                 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6264                 switch (intsize) {
6265                 case 'h':       uv = (unsigned short)uv; break;
6266                 default:        break;
6267                 case 'l':       uv = (unsigned long)uv; break;
6268                 case 'V':       break;
6269 #ifdef HAS_QUAD
6270                 case 'q':       uv = (Quad_t)uv; break;
6271 #endif
6272                 }
6273             }
6274
6275         integer:
6276             eptr = ebuf + sizeof ebuf;
6277             switch (base) {
6278                 unsigned dig;
6279             case 16:
6280                 if (!uv)
6281                     alt = FALSE;
6282                 p = (char*)((c == 'X')
6283                             ? "0123456789ABCDEF" : "0123456789abcdef");
6284                 do {
6285                     dig = uv & 15;
6286                     *--eptr = p[dig];
6287                 } while (uv >>= 4);
6288                 if (alt) {
6289                     esignbuf[esignlen++] = '0';
6290                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
6291                 }
6292                 break;
6293             case 8:
6294                 do {
6295                     dig = uv & 7;
6296                     *--eptr = '0' + dig;
6297                 } while (uv >>= 3);
6298                 if (alt && *eptr != '0')
6299                     *--eptr = '0';
6300                 break;
6301             case 2:
6302                 do {
6303                     dig = uv & 1;
6304                     *--eptr = '0' + dig;
6305                 } while (uv >>= 1);
6306                 if (alt) {
6307                     esignbuf[esignlen++] = '0';
6308                     esignbuf[esignlen++] = 'b';
6309                 }
6310                 break;
6311             default:            /* it had better be ten or less */
6312 #if defined(PERL_Y2KWARN)
6313                 if (ckWARN(WARN_Y2K)) {
6314                     STRLEN n;
6315                     char *s = SvPV(sv,n);
6316                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6317                         && (n == 2 || !isDIGIT(s[n-3])))
6318                     {
6319                         Perl_warner(aTHX_ WARN_Y2K,
6320                                     "Possible Y2K bug: %%%c %s",
6321                                     c, "format string following '19'");
6322                     }
6323                 }
6324 #endif
6325                 do {
6326                     dig = uv % base;
6327                     *--eptr = '0' + dig;
6328                 } while (uv /= base);
6329                 break;
6330             }
6331             elen = (ebuf + sizeof ebuf) - eptr;
6332             if (has_precis) {
6333                 if (precis > elen)
6334                     zeros = precis - elen;
6335                 else if (precis == 0 && elen == 1 && *eptr == '0')
6336                     elen = 0;
6337             }
6338             break;
6339
6340             /* FLOATING POINT */
6341
6342         case 'F':
6343             c = 'f';            /* maybe %F isn't supported here */
6344             /* FALL THROUGH */
6345         case 'e': case 'E':
6346         case 'f':
6347         case 'g': case 'G':
6348
6349             /* This is evil, but floating point is even more evil */
6350
6351             vectorize = FALSE;
6352             if (args)
6353                 nv = va_arg(*args, NV);
6354             else
6355                 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6356
6357             need = 0;
6358             if (c != 'e' && c != 'E') {
6359                 i = PERL_INT_MIN;
6360                 (void)Perl_frexp(nv, &i);
6361                 if (i == PERL_INT_MIN)
6362                     Perl_die(aTHX_ "panic: frexp");
6363                 if (i > 0)
6364                     need = BIT_DIGITS(i);
6365             }
6366             need += has_precis ? precis : 6; /* known default */
6367             if (need < width)
6368                 need = width;
6369
6370             need += 20; /* fudge factor */
6371             if (PL_efloatsize < need) {
6372                 Safefree(PL_efloatbuf);
6373                 PL_efloatsize = need + 20; /* more fudge */
6374                 New(906, PL_efloatbuf, PL_efloatsize, char);
6375                 PL_efloatbuf[0] = '\0';
6376             }
6377
6378             eptr = ebuf + sizeof ebuf;
6379             *--eptr = '\0';
6380             *--eptr = c;
6381 #ifdef USE_LONG_DOUBLE
6382             {
6383                 static char const my_prifldbl[] = PERL_PRIfldbl;
6384                 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6385                 while (p >= my_prifldbl) { *--eptr = *p--; }
6386             }
6387 #endif
6388             if (has_precis) {
6389                 base = precis;
6390                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6391                 *--eptr = '.';
6392             }
6393             if (width) {
6394                 base = width;
6395                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6396             }
6397             if (fill == '0')
6398                 *--eptr = fill;
6399             if (left)
6400                 *--eptr = '-';
6401             if (plus)
6402                 *--eptr = plus;
6403             if (alt)
6404                 *--eptr = '#';
6405             *--eptr = '%';
6406
6407             {
6408                 RESTORE_NUMERIC_STANDARD();
6409                 (void)sprintf(PL_efloatbuf, eptr, nv);
6410                 RESTORE_NUMERIC_LOCAL();
6411             }
6412
6413             eptr = PL_efloatbuf;
6414             elen = strlen(PL_efloatbuf);
6415             break;
6416
6417             /* SPECIAL */
6418
6419         case 'n':
6420             vectorize = FALSE;
6421             i = SvCUR(sv) - origlen;
6422             if (args) {
6423                 switch (intsize) {
6424                 case 'h':       *(va_arg(*args, short*)) = i; break;
6425                 default:        *(va_arg(*args, int*)) = i; break;
6426                 case 'l':       *(va_arg(*args, long*)) = i; break;
6427                 case 'V':       *(va_arg(*args, IV*)) = i; break;
6428 #ifdef HAS_QUAD
6429                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
6430 #endif
6431                 }
6432             }
6433             else if (svix < svmax)
6434                 sv_setuv_mg(svargs[svix++], (UV)i);
6435             continue;   /* not "break" */
6436
6437             /* UNKNOWN */
6438
6439         default:
6440       unknown:
6441             vectorize = FALSE;
6442             if (!args && ckWARN(WARN_PRINTF) &&
6443                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6444                 SV *msg = sv_newmortal();
6445                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6446                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6447                 if (c) {
6448                     if (isPRINT(c))
6449                         Perl_sv_catpvf(aTHX_ msg,
6450                                        "\"%%%c\"", c & 0xFF);
6451                     else
6452                         Perl_sv_catpvf(aTHX_ msg,
6453                                        "\"%%\\%03"UVof"\"",
6454                                        (UV)c & 0xFF);
6455                 } else
6456                     sv_catpv(msg, "end of string");
6457                 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6458             }
6459
6460             /* output mangled stuff ... */
6461             if (c == '\0')
6462                 --q;
6463             eptr = p;
6464             elen = q - p;
6465
6466             /* ... right here, because formatting flags should not apply */
6467             SvGROW(sv, SvCUR(sv) + elen + 1);
6468             p = SvEND(sv);
6469             memcpy(p, eptr, elen);
6470             p += elen;
6471             *p = '\0';
6472             SvCUR(sv) = p - SvPVX(sv);
6473             continue;   /* not "break" */
6474         }
6475
6476         have = esignlen + zeros + elen;
6477         need = (have > width ? have : width);
6478         gap = need - have;
6479
6480         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6481         p = SvEND(sv);
6482         if (esignlen && fill == '0') {
6483             for (i = 0; i < esignlen; i++)
6484                 *p++ = esignbuf[i];
6485         }
6486         if (gap && !left) {
6487             memset(p, fill, gap);
6488             p += gap;
6489         }
6490         if (esignlen && fill != '0') {
6491             for (i = 0; i < esignlen; i++)
6492                 *p++ = esignbuf[i];
6493         }
6494         if (zeros) {
6495             for (i = zeros; i; i--)
6496                 *p++ = '0';
6497         }
6498         if (elen) {
6499             memcpy(p, eptr, elen);
6500             p += elen;
6501         }
6502         if (gap && left) {
6503             memset(p, ' ', gap);
6504             p += gap;
6505         }
6506         if (vectorize) {
6507             if (veclen) {
6508                 memcpy(p, dotstr, dotstrlen);
6509                 p += dotstrlen;
6510             }
6511             else
6512                 vectorize = FALSE;              /* done iterating over vecstr */
6513         }
6514         if (is_utf)
6515             SvUTF8_on(sv);
6516         *p = '\0';
6517         SvCUR(sv) = p - SvPVX(sv);
6518         if (vectorize) {
6519             esignlen = 0;
6520             goto vector;
6521         }
6522     }
6523 }
6524
6525 #if defined(USE_ITHREADS)
6526
6527 #if defined(USE_THREADS)
6528 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
6529 #endif
6530
6531 #ifndef GpREFCNT_inc
6532 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6533 #endif
6534
6535
6536 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
6537 #define av_dup(s)       (AV*)sv_dup((SV*)s)
6538 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6539 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
6540 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6541 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
6542 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6543 #define io_dup(s)       (IO*)sv_dup((SV*)s)
6544 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6545 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
6546 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6547 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
6548 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
6549
6550 REGEXP *
6551 Perl_re_dup(pTHX_ REGEXP *r)
6552 {
6553     /* XXX fix when pmop->op_pmregexp becomes shared */
6554     return ReREFCNT_inc(r);
6555 }
6556
6557 PerlIO *
6558 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6559 {
6560     PerlIO *ret;
6561     if (!fp)
6562         return (PerlIO*)NULL;
6563
6564     /* look for it in the table first */
6565     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6566     if (ret)
6567         return ret;
6568
6569     /* create anew and remember what it is */
6570     ret = PerlIO_fdupopen(fp);
6571     ptr_table_store(PL_ptr_table, fp, ret);
6572     return ret;
6573 }
6574
6575 DIR *
6576 Perl_dirp_dup(pTHX_ DIR *dp)
6577 {
6578     if (!dp)
6579         return (DIR*)NULL;
6580     /* XXX TODO */
6581     return dp;
6582 }
6583
6584 GP *
6585 Perl_gp_dup(pTHX_ GP *gp)
6586 {
6587     GP *ret;
6588     if (!gp)
6589         return (GP*)NULL;
6590     /* look for it in the table first */
6591     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6592     if (ret)
6593         return ret;
6594
6595     /* create anew and remember what it is */
6596     Newz(0, ret, 1, GP);
6597     ptr_table_store(PL_ptr_table, gp, ret);
6598
6599     /* clone */
6600     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
6601     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
6602     ret->gp_io          = io_dup_inc(gp->gp_io);
6603     ret->gp_form        = cv_dup_inc(gp->gp_form);
6604     ret->gp_av          = av_dup_inc(gp->gp_av);
6605     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
6606     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
6607     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
6608     ret->gp_cvgen       = gp->gp_cvgen;
6609     ret->gp_flags       = gp->gp_flags;
6610     ret->gp_line        = gp->gp_line;
6611     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
6612     return ret;
6613 }
6614
6615 MAGIC *
6616 Perl_mg_dup(pTHX_ MAGIC *mg)
6617 {
6618     MAGIC *mgret = (MAGIC*)NULL;
6619     MAGIC *mgprev;
6620     if (!mg)
6621         return (MAGIC*)NULL;
6622     /* look for it in the table first */
6623     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6624     if (mgret)
6625         return mgret;
6626
6627     for (; mg; mg = mg->mg_moremagic) {
6628         MAGIC *nmg;
6629         Newz(0, nmg, 1, MAGIC);
6630         if (!mgret)
6631             mgret = nmg;
6632         else
6633             mgprev->mg_moremagic = nmg;
6634         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
6635         nmg->mg_private = mg->mg_private;
6636         nmg->mg_type    = mg->mg_type;
6637         nmg->mg_flags   = mg->mg_flags;
6638         if (mg->mg_type == 'r') {
6639             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6640         }
6641         else {
6642             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6643                               ? sv_dup_inc(mg->mg_obj)
6644                               : sv_dup(mg->mg_obj);
6645         }
6646         nmg->mg_len     = mg->mg_len;
6647         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
6648         if (mg->mg_ptr && mg->mg_type != 'g') {
6649             if (mg->mg_len >= 0) {
6650                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
6651                 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6652                     AMT *amtp = (AMT*)mg->mg_ptr;
6653                     AMT *namtp = (AMT*)nmg->mg_ptr;
6654                     I32 i;
6655                     for (i = 1; i < NofAMmeth; i++) {
6656                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
6657                     }
6658                 }
6659             }
6660             else if (mg->mg_len == HEf_SVKEY)
6661                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6662         }
6663         mgprev = nmg;
6664     }
6665     return mgret;
6666 }
6667
6668 PTR_TBL_t *
6669 Perl_ptr_table_new(pTHX)
6670 {
6671     PTR_TBL_t *tbl;
6672     Newz(0, tbl, 1, PTR_TBL_t);
6673     tbl->tbl_max        = 511;
6674     tbl->tbl_items      = 0;
6675     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6676     return tbl;
6677 }
6678
6679 void *
6680 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6681 {
6682     PTR_TBL_ENT_t *tblent;
6683     UV hash = PTR2UV(sv);
6684     assert(tbl);
6685     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6686     for (; tblent; tblent = tblent->next) {
6687         if (tblent->oldval == sv)
6688             return tblent->newval;
6689     }
6690     return (void*)NULL;
6691 }
6692
6693 void
6694 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6695 {
6696     PTR_TBL_ENT_t *tblent, **otblent;
6697     /* XXX this may be pessimal on platforms where pointers aren't good
6698      * hash values e.g. if they grow faster in the most significant
6699      * bits */
6700     UV hash = PTR2UV(oldv);
6701     bool i = 1;
6702
6703     assert(tbl);
6704     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6705     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6706         if (tblent->oldval == oldv) {
6707             tblent->newval = newv;
6708             tbl->tbl_items++;
6709             return;
6710         }
6711     }
6712     Newz(0, tblent, 1, PTR_TBL_ENT_t);
6713     tblent->oldval = oldv;
6714     tblent->newval = newv;
6715     tblent->next = *otblent;
6716     *otblent = tblent;
6717     tbl->tbl_items++;
6718     if (i && tbl->tbl_items > tbl->tbl_max)
6719         ptr_table_split(tbl);
6720 }
6721
6722 void
6723 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6724 {
6725     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6726     UV oldsize = tbl->tbl_max + 1;
6727     UV newsize = oldsize * 2;
6728     UV i;
6729
6730     Renew(ary, newsize, PTR_TBL_ENT_t*);
6731     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6732     tbl->tbl_max = --newsize;
6733     tbl->tbl_ary = ary;
6734     for (i=0; i < oldsize; i++, ary++) {
6735         PTR_TBL_ENT_t **curentp, **entp, *ent;
6736         if (!*ary)
6737             continue;
6738         curentp = ary + oldsize;
6739         for (entp = ary, ent = *ary; ent; ent = *entp) {
6740             if ((newsize & PTR2UV(ent->oldval)) != i) {
6741                 *entp = ent->next;
6742                 ent->next = *curentp;
6743                 *curentp = ent;
6744                 continue;
6745             }
6746             else
6747                 entp = &ent->next;
6748         }
6749     }
6750 }
6751
6752 #ifdef DEBUGGING
6753 char *PL_watch_pvx;
6754 #endif
6755
6756 SV *
6757 Perl_sv_dup(pTHX_ SV *sstr)
6758 {
6759     SV *dstr;
6760
6761     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6762         return Nullsv;
6763     /* look for it in the table first */
6764     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6765     if (dstr)
6766         return dstr;
6767
6768     /* create anew and remember what it is */
6769     new_SV(dstr);
6770     ptr_table_store(PL_ptr_table, sstr, dstr);
6771
6772     /* clone */
6773     SvFLAGS(dstr)       = SvFLAGS(sstr);
6774     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
6775     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
6776
6777 #ifdef DEBUGGING
6778     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6779         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6780                       PL_watch_pvx, SvPVX(sstr));
6781 #endif
6782
6783     switch (SvTYPE(sstr)) {
6784     case SVt_NULL:
6785         SvANY(dstr)     = NULL;
6786         break;
6787     case SVt_IV:
6788         SvANY(dstr)     = new_XIV();
6789         SvIVX(dstr)     = SvIVX(sstr);
6790         break;
6791     case SVt_NV:
6792         SvANY(dstr)     = new_XNV();
6793         SvNVX(dstr)     = SvNVX(sstr);
6794         break;
6795     case SVt_RV:
6796         SvANY(dstr)     = new_XRV();
6797         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
6798         break;
6799     case SVt_PV:
6800         SvANY(dstr)     = new_XPV();
6801         SvCUR(dstr)     = SvCUR(sstr);
6802         SvLEN(dstr)     = SvLEN(sstr);
6803         if (SvROK(sstr))
6804             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6805         else if (SvPVX(sstr) && SvLEN(sstr))
6806             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6807         else
6808             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6809         break;
6810     case SVt_PVIV:
6811         SvANY(dstr)     = new_XPVIV();
6812         SvCUR(dstr)     = SvCUR(sstr);
6813         SvLEN(dstr)     = SvLEN(sstr);
6814         SvIVX(dstr)     = SvIVX(sstr);
6815         if (SvROK(sstr))
6816             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6817         else if (SvPVX(sstr) && SvLEN(sstr))
6818             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6819         else
6820             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6821         break;
6822     case SVt_PVNV:
6823         SvANY(dstr)     = new_XPVNV();
6824         SvCUR(dstr)     = SvCUR(sstr);
6825         SvLEN(dstr)     = SvLEN(sstr);
6826         SvIVX(dstr)     = SvIVX(sstr);
6827         SvNVX(dstr)     = SvNVX(sstr);
6828         if (SvROK(sstr))
6829             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6830         else if (SvPVX(sstr) && SvLEN(sstr))
6831             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6832         else
6833             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6834         break;
6835     case SVt_PVMG:
6836         SvANY(dstr)     = new_XPVMG();
6837         SvCUR(dstr)     = SvCUR(sstr);
6838         SvLEN(dstr)     = SvLEN(sstr);
6839         SvIVX(dstr)     = SvIVX(sstr);
6840         SvNVX(dstr)     = SvNVX(sstr);
6841         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6842         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6843         if (SvROK(sstr))
6844             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6845         else if (SvPVX(sstr) && SvLEN(sstr))
6846             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6847         else
6848             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6849         break;
6850     case SVt_PVBM:
6851         SvANY(dstr)     = new_XPVBM();
6852         SvCUR(dstr)     = SvCUR(sstr);
6853         SvLEN(dstr)     = SvLEN(sstr);
6854         SvIVX(dstr)     = SvIVX(sstr);
6855         SvNVX(dstr)     = SvNVX(sstr);
6856         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6857         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6858         if (SvROK(sstr))
6859             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6860         else if (SvPVX(sstr) && SvLEN(sstr))
6861             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6862         else
6863             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6864         BmRARE(dstr)    = BmRARE(sstr);
6865         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
6866         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6867         break;
6868     case SVt_PVLV:
6869         SvANY(dstr)     = new_XPVLV();
6870         SvCUR(dstr)     = SvCUR(sstr);
6871         SvLEN(dstr)     = SvLEN(sstr);
6872         SvIVX(dstr)     = SvIVX(sstr);
6873         SvNVX(dstr)     = SvNVX(sstr);
6874         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6875         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6876         if (SvROK(sstr))
6877             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6878         else if (SvPVX(sstr) && SvLEN(sstr))
6879             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6880         else
6881             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6882         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
6883         LvTARGLEN(dstr) = LvTARGLEN(sstr);
6884         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
6885         LvTYPE(dstr)    = LvTYPE(sstr);
6886         break;
6887     case SVt_PVGV:
6888         SvANY(dstr)     = new_XPVGV();
6889         SvCUR(dstr)     = SvCUR(sstr);
6890         SvLEN(dstr)     = SvLEN(sstr);
6891         SvIVX(dstr)     = SvIVX(sstr);
6892         SvNVX(dstr)     = SvNVX(sstr);
6893         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6894         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6895         if (SvROK(sstr))
6896             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6897         else if (SvPVX(sstr) && SvLEN(sstr))
6898             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6899         else
6900             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6901         GvNAMELEN(dstr) = GvNAMELEN(sstr);
6902         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6903         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
6904         GvFLAGS(dstr)   = GvFLAGS(sstr);
6905         GvGP(dstr)      = gp_dup(GvGP(sstr));
6906         (void)GpREFCNT_inc(GvGP(dstr));
6907         break;
6908     case SVt_PVIO:
6909         SvANY(dstr)     = new_XPVIO();
6910         SvCUR(dstr)     = SvCUR(sstr);
6911         SvLEN(dstr)     = SvLEN(sstr);
6912         SvIVX(dstr)     = SvIVX(sstr);
6913         SvNVX(dstr)     = SvNVX(sstr);
6914         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6915         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6916         if (SvROK(sstr))
6917             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6918         else if (SvPVX(sstr) && SvLEN(sstr))
6919             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6920         else
6921             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6922         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6923         if (IoOFP(sstr) == IoIFP(sstr))
6924             IoOFP(dstr) = IoIFP(dstr);
6925         else
6926             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6927         /* PL_rsfp_filters entries have fake IoDIRP() */
6928         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6929             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
6930         else
6931             IoDIRP(dstr)        = IoDIRP(sstr);
6932         IoLINES(dstr)           = IoLINES(sstr);
6933         IoPAGE(dstr)            = IoPAGE(sstr);
6934         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
6935         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
6936         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
6937         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
6938         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
6939         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
6940         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
6941         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
6942         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
6943         IoTYPE(dstr)            = IoTYPE(sstr);
6944         IoFLAGS(dstr)           = IoFLAGS(sstr);
6945         break;
6946     case SVt_PVAV:
6947         SvANY(dstr)     = new_XPVAV();
6948         SvCUR(dstr)     = SvCUR(sstr);
6949         SvLEN(dstr)     = SvLEN(sstr);
6950         SvIVX(dstr)     = SvIVX(sstr);
6951         SvNVX(dstr)     = SvNVX(sstr);
6952         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6953         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6954         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6955         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6956         if (AvARRAY((AV*)sstr)) {
6957             SV **dst_ary, **src_ary;
6958             SSize_t items = AvFILLp((AV*)sstr) + 1;
6959
6960             src_ary = AvARRAY((AV*)sstr);
6961             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6962             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6963             SvPVX(dstr) = (char*)dst_ary;
6964             AvALLOC((AV*)dstr) = dst_ary;
6965             if (AvREAL((AV*)sstr)) {
6966                 while (items-- > 0)
6967                     *dst_ary++ = sv_dup_inc(*src_ary++);
6968             }
6969             else {
6970                 while (items-- > 0)
6971                     *dst_ary++ = sv_dup(*src_ary++);
6972             }
6973             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6974             while (items-- > 0) {
6975                 *dst_ary++ = &PL_sv_undef;
6976             }
6977         }
6978         else {
6979             SvPVX(dstr)         = Nullch;
6980             AvALLOC((AV*)dstr)  = (SV**)NULL;
6981         }
6982         break;
6983     case SVt_PVHV:
6984         SvANY(dstr)     = new_XPVHV();
6985         SvCUR(dstr)     = SvCUR(sstr);
6986         SvLEN(dstr)     = SvLEN(sstr);
6987         SvIVX(dstr)     = SvIVX(sstr);
6988         SvNVX(dstr)     = SvNVX(sstr);
6989         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6990         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6991         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
6992         if (HvARRAY((HV*)sstr)) {
6993             STRLEN i = 0;
6994             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6995             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6996             Newz(0, dxhv->xhv_array,
6997                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6998             while (i <= sxhv->xhv_max) {
6999                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7000                                                     !!HvSHAREKEYS(sstr));
7001                 ++i;
7002             }
7003             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7004         }
7005         else {
7006             SvPVX(dstr)         = Nullch;
7007             HvEITER((HV*)dstr)  = (HE*)NULL;
7008         }
7009         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
7010         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
7011         break;
7012     case SVt_PVFM:
7013         SvANY(dstr)     = new_XPVFM();
7014         FmLINES(dstr)   = FmLINES(sstr);
7015         goto dup_pvcv;
7016         /* NOTREACHED */
7017     case SVt_PVCV:
7018         SvANY(dstr)     = new_XPVCV();
7019 dup_pvcv:
7020         SvCUR(dstr)     = SvCUR(sstr);
7021         SvLEN(dstr)     = SvLEN(sstr);
7022         SvIVX(dstr)     = SvIVX(sstr);
7023         SvNVX(dstr)     = SvNVX(sstr);
7024         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
7025         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
7026         if (SvPVX(sstr) && SvLEN(sstr))
7027             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7028         else
7029             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
7030         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7031         CvSTART(dstr)   = CvSTART(sstr);
7032         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
7033         CvXSUB(dstr)    = CvXSUB(sstr);
7034         CvXSUBANY(dstr) = CvXSUBANY(sstr);
7035         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
7036         CvDEPTH(dstr)   = CvDEPTH(sstr);
7037         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7038             /* XXX padlists are real, but pretend to be not */
7039             AvREAL_on(CvPADLIST(sstr));
7040             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
7041             AvREAL_off(CvPADLIST(sstr));
7042             AvREAL_off(CvPADLIST(dstr));
7043         }
7044         else
7045             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
7046         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7047         CvFLAGS(dstr)   = CvFLAGS(sstr);
7048         break;
7049     default:
7050         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7051         break;
7052     }
7053
7054     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7055         ++PL_sv_objcount;
7056
7057     return dstr;
7058 }
7059
7060 PERL_CONTEXT *
7061 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7062 {
7063     PERL_CONTEXT *ncxs;
7064
7065     if (!cxs)
7066         return (PERL_CONTEXT*)NULL;
7067
7068     /* look for it in the table first */
7069     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7070     if (ncxs)
7071         return ncxs;
7072
7073     /* create anew and remember what it is */
7074     Newz(56, ncxs, max + 1, PERL_CONTEXT);
7075     ptr_table_store(PL_ptr_table, cxs, ncxs);
7076
7077     while (ix >= 0) {
7078         PERL_CONTEXT *cx = &cxs[ix];
7079         PERL_CONTEXT *ncx = &ncxs[ix];
7080         ncx->cx_type    = cx->cx_type;
7081         if (CxTYPE(cx) == CXt_SUBST) {
7082             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7083         }
7084         else {
7085             ncx->blk_oldsp      = cx->blk_oldsp;
7086             ncx->blk_oldcop     = cx->blk_oldcop;
7087             ncx->blk_oldretsp   = cx->blk_oldretsp;
7088             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
7089             ncx->blk_oldscopesp = cx->blk_oldscopesp;
7090             ncx->blk_oldpm      = cx->blk_oldpm;
7091             ncx->blk_gimme      = cx->blk_gimme;
7092             switch (CxTYPE(cx)) {
7093             case CXt_SUB:
7094                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
7095                                            ? cv_dup_inc(cx->blk_sub.cv)
7096                                            : cv_dup(cx->blk_sub.cv));
7097                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
7098                                            ? av_dup_inc(cx->blk_sub.argarray)
7099                                            : Nullav);
7100                 ncx->blk_sub.savearray  = av_dup(cx->blk_sub.savearray);
7101                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
7102                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
7103                 ncx->blk_sub.lval       = cx->blk_sub.lval;
7104                 break;
7105             case CXt_EVAL:
7106                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7107                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7108                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7109                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7110                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text);
7111                 break;
7112             case CXt_LOOP:
7113                 ncx->blk_loop.label     = cx->blk_loop.label;
7114                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
7115                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
7116                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
7117                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
7118                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
7119                                            ? cx->blk_loop.iterdata
7120                                            : gv_dup((GV*)cx->blk_loop.iterdata));
7121                 ncx->blk_loop.oldcurpad
7122                     = (SV**)ptr_table_fetch(PL_ptr_table,
7123                                             cx->blk_loop.oldcurpad);
7124                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave);
7125                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval);
7126                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary);
7127                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
7128                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
7129                 break;
7130             case CXt_FORMAT:
7131                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv);
7132                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv);
7133                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv);
7134                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
7135                 break;
7136             case CXt_BLOCK:
7137             case CXt_NULL:
7138                 break;
7139             }
7140         }
7141         --ix;
7142     }
7143     return ncxs;
7144 }
7145
7146 PERL_SI *
7147 Perl_si_dup(pTHX_ PERL_SI *si)
7148 {
7149     PERL_SI *nsi;
7150
7151     if (!si)
7152         return (PERL_SI*)NULL;
7153
7154     /* look for it in the table first */
7155     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7156     if (nsi)
7157         return nsi;
7158
7159     /* create anew and remember what it is */
7160     Newz(56, nsi, 1, PERL_SI);
7161     ptr_table_store(PL_ptr_table, si, nsi);
7162
7163     nsi->si_stack       = av_dup_inc(si->si_stack);
7164     nsi->si_cxix        = si->si_cxix;
7165     nsi->si_cxmax       = si->si_cxmax;
7166     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7167     nsi->si_type        = si->si_type;
7168     nsi->si_prev        = si_dup(si->si_prev);
7169     nsi->si_next        = si_dup(si->si_next);
7170     nsi->si_markoff     = si->si_markoff;
7171
7172     return nsi;
7173 }
7174
7175 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
7176 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
7177 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
7178 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
7179 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
7180 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
7181 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
7182 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
7183 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
7184 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
7185 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7186 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7187
7188 /* XXXXX todo */
7189 #define pv_dup_inc(p)   SAVEPV(p)
7190 #define pv_dup(p)       SAVEPV(p)
7191 #define svp_dup_inc(p,pp)       any_dup(p,pp)
7192
7193 void *
7194 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7195 {
7196     void *ret;
7197
7198     if (!v)
7199         return (void*)NULL;
7200
7201     /* look for it in the table first */
7202     ret = ptr_table_fetch(PL_ptr_table, v);
7203     if (ret)
7204         return ret;
7205
7206     /* see if it is part of the interpreter structure */
7207     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7208         ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7209     else
7210         ret = v;
7211
7212     return ret;
7213 }
7214
7215 ANY *
7216 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7217 {
7218     ANY *ss     = proto_perl->Tsavestack;
7219     I32 ix      = proto_perl->Tsavestack_ix;
7220     I32 max     = proto_perl->Tsavestack_max;
7221     ANY *nss;
7222     SV *sv;
7223     GV *gv;
7224     AV *av;
7225     HV *hv;
7226     void* ptr;
7227     int intval;
7228     long longval;
7229     GP *gp;
7230     IV iv;
7231     I32 i;
7232     char *c;
7233     void (*dptr) (void*);
7234     void (*dxptr) (pTHXo_ void*);
7235     OP *o;
7236
7237     Newz(54, nss, max, ANY);
7238
7239     while (ix > 0) {
7240         i = POPINT(ss,ix);
7241         TOPINT(nss,ix) = i;
7242         switch (i) {
7243         case SAVEt_ITEM:                        /* normal string */
7244             sv = (SV*)POPPTR(ss,ix);
7245             TOPPTR(nss,ix) = sv_dup_inc(sv);
7246             sv = (SV*)POPPTR(ss,ix);
7247             TOPPTR(nss,ix) = sv_dup_inc(sv);
7248             break;
7249         case SAVEt_SV:                          /* scalar reference */
7250             sv = (SV*)POPPTR(ss,ix);
7251             TOPPTR(nss,ix) = sv_dup_inc(sv);
7252             gv = (GV*)POPPTR(ss,ix);
7253             TOPPTR(nss,ix) = gv_dup_inc(gv);
7254             break;
7255         case SAVEt_GENERIC_PVREF:               /* generic char* */
7256             c = (char*)POPPTR(ss,ix);
7257             TOPPTR(nss,ix) = pv_dup(c);
7258             ptr = POPPTR(ss,ix);
7259             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7260             break;
7261         case SAVEt_GENERIC_SVREF:               /* generic sv */
7262         case SAVEt_SVREF:                       /* scalar reference */
7263             sv = (SV*)POPPTR(ss,ix);
7264             TOPPTR(nss,ix) = sv_dup_inc(sv);
7265             ptr = POPPTR(ss,ix);
7266             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7267             break;
7268         case SAVEt_AV:                          /* array reference */
7269             av = (AV*)POPPTR(ss,ix);
7270             TOPPTR(nss,ix) = av_dup_inc(av);
7271             gv = (GV*)POPPTR(ss,ix);
7272             TOPPTR(nss,ix) = gv_dup(gv);
7273             break;
7274         case SAVEt_HV:                          /* hash reference */
7275             hv = (HV*)POPPTR(ss,ix);
7276             TOPPTR(nss,ix) = hv_dup_inc(hv);
7277             gv = (GV*)POPPTR(ss,ix);
7278             TOPPTR(nss,ix) = gv_dup(gv);
7279             break;
7280         case SAVEt_INT:                         /* int reference */
7281             ptr = POPPTR(ss,ix);
7282             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7283             intval = (int)POPINT(ss,ix);
7284             TOPINT(nss,ix) = intval;
7285             break;
7286         case SAVEt_LONG:                        /* long reference */
7287             ptr = POPPTR(ss,ix);
7288             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7289             longval = (long)POPLONG(ss,ix);
7290             TOPLONG(nss,ix) = longval;
7291             break;
7292         case SAVEt_I32:                         /* I32 reference */
7293         case SAVEt_I16:                         /* I16 reference */
7294         case SAVEt_I8:                          /* I8 reference */
7295             ptr = POPPTR(ss,ix);
7296             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7297             i = POPINT(ss,ix);
7298             TOPINT(nss,ix) = i;
7299             break;
7300         case SAVEt_IV:                          /* IV reference */
7301             ptr = POPPTR(ss,ix);
7302             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7303             iv = POPIV(ss,ix);
7304             TOPIV(nss,ix) = iv;
7305             break;
7306         case SAVEt_SPTR:                        /* SV* reference */
7307             ptr = POPPTR(ss,ix);
7308             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7309             sv = (SV*)POPPTR(ss,ix);
7310             TOPPTR(nss,ix) = sv_dup(sv);
7311             break;
7312         case SAVEt_VPTR:                        /* random* reference */
7313             ptr = POPPTR(ss,ix);
7314             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7315             ptr = POPPTR(ss,ix);
7316             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7317             break;
7318         case SAVEt_PPTR:                        /* char* reference */
7319             ptr = POPPTR(ss,ix);
7320             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7321             c = (char*)POPPTR(ss,ix);
7322             TOPPTR(nss,ix) = pv_dup(c);
7323             break;
7324         case SAVEt_HPTR:                        /* HV* reference */
7325             ptr = POPPTR(ss,ix);
7326             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7327             hv = (HV*)POPPTR(ss,ix);
7328             TOPPTR(nss,ix) = hv_dup(hv);
7329             break;
7330         case SAVEt_APTR:                        /* AV* reference */
7331             ptr = POPPTR(ss,ix);
7332             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7333             av = (AV*)POPPTR(ss,ix);
7334             TOPPTR(nss,ix) = av_dup(av);
7335             break;
7336         case SAVEt_NSTAB:
7337             gv = (GV*)POPPTR(ss,ix);
7338             TOPPTR(nss,ix) = gv_dup(gv);
7339             break;
7340         case SAVEt_GP:                          /* scalar reference */
7341             gp = (GP*)POPPTR(ss,ix);
7342             TOPPTR(nss,ix) = gp = gp_dup(gp);
7343             (void)GpREFCNT_inc(gp);
7344             gv = (GV*)POPPTR(ss,ix);
7345             TOPPTR(nss,ix) = gv_dup_inc(c);
7346             c = (char*)POPPTR(ss,ix);
7347             TOPPTR(nss,ix) = pv_dup(c);
7348             iv = POPIV(ss,ix);
7349             TOPIV(nss,ix) = iv;
7350             iv = POPIV(ss,ix);
7351             TOPIV(nss,ix) = iv;
7352             break;
7353         case SAVEt_FREESV:
7354             sv = (SV*)POPPTR(ss,ix);
7355             TOPPTR(nss,ix) = sv_dup_inc(sv);
7356             break;
7357         case SAVEt_FREEOP:
7358             ptr = POPPTR(ss,ix);
7359             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7360                 /* these are assumed to be refcounted properly */
7361                 switch (((OP*)ptr)->op_type) {
7362                 case OP_LEAVESUB:
7363                 case OP_LEAVESUBLV:
7364                 case OP_LEAVEEVAL:
7365                 case OP_LEAVE:
7366                 case OP_SCOPE:
7367                 case OP_LEAVEWRITE:
7368                     TOPPTR(nss,ix) = ptr;
7369                     o = (OP*)ptr;
7370                     OpREFCNT_inc(o);
7371                     break;
7372                 default:
7373                     TOPPTR(nss,ix) = Nullop;
7374                     break;
7375                 }
7376             }
7377             else
7378                 TOPPTR(nss,ix) = Nullop;
7379             break;
7380         case SAVEt_FREEPV:
7381             c = (char*)POPPTR(ss,ix);
7382             TOPPTR(nss,ix) = pv_dup_inc(c);
7383             break;
7384         case SAVEt_CLEARSV:
7385             longval = POPLONG(ss,ix);
7386             TOPLONG(nss,ix) = longval;
7387             break;
7388         case SAVEt_DELETE:
7389             hv = (HV*)POPPTR(ss,ix);
7390             TOPPTR(nss,ix) = hv_dup_inc(hv);
7391             c = (char*)POPPTR(ss,ix);
7392             TOPPTR(nss,ix) = pv_dup_inc(c);
7393             i = POPINT(ss,ix);
7394             TOPINT(nss,ix) = i;
7395             break;
7396         case SAVEt_DESTRUCTOR:
7397             ptr = POPPTR(ss,ix);
7398             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
7399             dptr = POPDPTR(ss,ix);
7400             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7401             break;
7402         case SAVEt_DESTRUCTOR_X:
7403             ptr = POPPTR(ss,ix);
7404             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
7405             dxptr = POPDXPTR(ss,ix);
7406             TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7407             break;
7408         case SAVEt_REGCONTEXT:
7409         case SAVEt_ALLOC:
7410             i = POPINT(ss,ix);
7411             TOPINT(nss,ix) = i;
7412             ix -= i;
7413             break;
7414         case SAVEt_STACK_POS:           /* Position on Perl stack */
7415             i = POPINT(ss,ix);
7416             TOPINT(nss,ix) = i;
7417             break;
7418         case SAVEt_AELEM:               /* array element */
7419             sv = (SV*)POPPTR(ss,ix);
7420             TOPPTR(nss,ix) = sv_dup_inc(sv);
7421             i = POPINT(ss,ix);
7422             TOPINT(nss,ix) = i;
7423             av = (AV*)POPPTR(ss,ix);
7424             TOPPTR(nss,ix) = av_dup_inc(av);
7425             break;
7426         case SAVEt_HELEM:               /* hash element */
7427             sv = (SV*)POPPTR(ss,ix);
7428             TOPPTR(nss,ix) = sv_dup_inc(sv);
7429             sv = (SV*)POPPTR(ss,ix);
7430             TOPPTR(nss,ix) = sv_dup_inc(sv);
7431             hv = (HV*)POPPTR(ss,ix);
7432             TOPPTR(nss,ix) = hv_dup_inc(hv);
7433             break;
7434         case SAVEt_OP:
7435             ptr = POPPTR(ss,ix);
7436             TOPPTR(nss,ix) = ptr;
7437             break;
7438         case SAVEt_HINTS:
7439             i = POPINT(ss,ix);
7440             TOPINT(nss,ix) = i;
7441             break;
7442         case SAVEt_COMPPAD:
7443             av = (AV*)POPPTR(ss,ix);
7444             TOPPTR(nss,ix) = av_dup(av);
7445             break;
7446         default:
7447             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7448         }
7449     }
7450
7451     return nss;
7452 }
7453
7454 #ifdef PERL_OBJECT
7455 #include "XSUB.h"
7456 #endif
7457
7458 PerlInterpreter *
7459 perl_clone(PerlInterpreter *proto_perl, UV flags)
7460 {
7461 #ifdef PERL_OBJECT
7462     CPerlObj *pPerl = (CPerlObj*)proto_perl;
7463 #endif
7464
7465 #ifdef PERL_IMPLICIT_SYS
7466     return perl_clone_using(proto_perl, flags,
7467                             proto_perl->IMem,
7468                             proto_perl->IMemShared,
7469                             proto_perl->IMemParse,
7470                             proto_perl->IEnv,
7471                             proto_perl->IStdIO,
7472                             proto_perl->ILIO,
7473                             proto_perl->IDir,
7474                             proto_perl->ISock,
7475                             proto_perl->IProc);
7476 }
7477
7478 PerlInterpreter *
7479 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7480                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
7481                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7482                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7483                  struct IPerlDir* ipD, struct IPerlSock* ipS,
7484                  struct IPerlProc* ipP)
7485 {
7486     /* XXX many of the string copies here can be optimized if they're
7487      * constants; they need to be allocated as common memory and just
7488      * their pointers copied. */
7489
7490     IV i;
7491 #  ifdef PERL_OBJECT
7492     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7493                                         ipD, ipS, ipP);
7494     PERL_SET_THX(pPerl);
7495 #  else         /* !PERL_OBJECT */
7496     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7497     PERL_SET_THX(my_perl);
7498
7499 #    ifdef DEBUGGING
7500     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7501     PL_markstack = 0;
7502     PL_scopestack = 0;
7503     PL_savestack = 0;
7504     PL_retstack = 0;
7505 #    else       /* !DEBUGGING */
7506     Zero(my_perl, 1, PerlInterpreter);
7507 #    endif      /* DEBUGGING */
7508
7509     /* host pointers */
7510     PL_Mem              = ipM;
7511     PL_MemShared        = ipMS;
7512     PL_MemParse         = ipMP;
7513     PL_Env              = ipE;
7514     PL_StdIO            = ipStd;
7515     PL_LIO              = ipLIO;
7516     PL_Dir              = ipD;
7517     PL_Sock             = ipS;
7518     PL_Proc             = ipP;
7519 #  endif        /* PERL_OBJECT */
7520 #else           /* !PERL_IMPLICIT_SYS */
7521     IV i;
7522     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7523     PERL_SET_THX(my_perl);
7524
7525 #    ifdef DEBUGGING
7526     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7527     PL_markstack = 0;
7528     PL_scopestack = 0;
7529     PL_savestack = 0;
7530     PL_retstack = 0;
7531 #    else       /* !DEBUGGING */
7532     Zero(my_perl, 1, PerlInterpreter);
7533 #    endif      /* DEBUGGING */
7534 #endif          /* PERL_IMPLICIT_SYS */
7535
7536     /* arena roots */
7537     PL_xiv_arenaroot    = NULL;
7538     PL_xiv_root         = NULL;
7539     PL_xnv_arenaroot    = NULL;
7540     PL_xnv_root         = NULL;
7541     PL_xrv_arenaroot    = NULL;
7542     PL_xrv_root         = NULL;
7543     PL_xpv_arenaroot    = NULL;
7544     PL_xpv_root         = NULL;
7545     PL_xpviv_arenaroot  = NULL;
7546     PL_xpviv_root       = NULL;
7547     PL_xpvnv_arenaroot  = NULL;
7548     PL_xpvnv_root       = NULL;
7549     PL_xpvcv_arenaroot  = NULL;
7550     PL_xpvcv_root       = NULL;
7551     PL_xpvav_arenaroot  = NULL;
7552     PL_xpvav_root       = NULL;
7553     PL_xpvhv_arenaroot  = NULL;
7554     PL_xpvhv_root       = NULL;
7555     PL_xpvmg_arenaroot  = NULL;
7556     PL_xpvmg_root       = NULL;
7557     PL_xpvlv_arenaroot  = NULL;
7558     PL_xpvlv_root       = NULL;
7559     PL_xpvbm_arenaroot  = NULL;
7560     PL_xpvbm_root       = NULL;
7561     PL_he_arenaroot     = NULL;
7562     PL_he_root          = NULL;
7563     PL_nice_chunk       = NULL;
7564     PL_nice_chunk_size  = 0;
7565     PL_sv_count         = 0;
7566     PL_sv_objcount      = 0;
7567     PL_sv_root          = Nullsv;
7568     PL_sv_arenaroot     = Nullsv;
7569
7570     PL_debug            = proto_perl->Idebug;
7571
7572     /* create SV map for pointer relocation */
7573     PL_ptr_table = ptr_table_new();
7574
7575     /* initialize these special pointers as early as possible */
7576     SvANY(&PL_sv_undef)         = NULL;
7577     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
7578     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
7579     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7580
7581 #ifdef PERL_OBJECT
7582     SvUPGRADE(&PL_sv_no, SVt_PVNV);
7583 #else
7584     SvANY(&PL_sv_no)            = new_XPVNV();
7585 #endif
7586     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
7587     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7588     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
7589     SvCUR(&PL_sv_no)            = 0;
7590     SvLEN(&PL_sv_no)            = 1;
7591     SvNVX(&PL_sv_no)            = 0;
7592     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7593
7594 #ifdef PERL_OBJECT
7595     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7596 #else
7597     SvANY(&PL_sv_yes)           = new_XPVNV();
7598 #endif
7599     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
7600     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7601     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
7602     SvCUR(&PL_sv_yes)           = 1;
7603     SvLEN(&PL_sv_yes)           = 2;
7604     SvNVX(&PL_sv_yes)           = 1;
7605     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7606
7607     /* create shared string table */
7608     PL_strtab           = newHV();
7609     HvSHAREKEYS_off(PL_strtab);
7610     hv_ksplit(PL_strtab, 512);
7611     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7612
7613     PL_compiling                = proto_perl->Icompiling;
7614     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
7615     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
7616     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7617     if (!specialWARN(PL_compiling.cop_warnings))
7618         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7619     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7620
7621     /* pseudo environmental stuff */
7622     PL_origargc         = proto_perl->Iorigargc;
7623     i = PL_origargc;
7624     New(0, PL_origargv, i+1, char*);
7625     PL_origargv[i] = '\0';
7626     while (i-- > 0) {
7627         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
7628     }
7629     PL_envgv            = gv_dup(proto_perl->Ienvgv);
7630     PL_incgv            = gv_dup(proto_perl->Iincgv);
7631     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
7632     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
7633     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
7634     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
7635
7636     /* switches */
7637     PL_minus_c          = proto_perl->Iminus_c;
7638     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
7639     PL_localpatches     = proto_perl->Ilocalpatches;
7640     PL_splitstr         = proto_perl->Isplitstr;
7641     PL_preprocess       = proto_perl->Ipreprocess;
7642     PL_minus_n          = proto_perl->Iminus_n;
7643     PL_minus_p          = proto_perl->Iminus_p;
7644     PL_minus_l          = proto_perl->Iminus_l;
7645     PL_minus_a          = proto_perl->Iminus_a;
7646     PL_minus_F          = proto_perl->Iminus_F;
7647     PL_doswitches       = proto_perl->Idoswitches;
7648     PL_dowarn           = proto_perl->Idowarn;
7649     PL_doextract        = proto_perl->Idoextract;
7650     PL_sawampersand     = proto_perl->Isawampersand;
7651     PL_unsafe           = proto_perl->Iunsafe;
7652     PL_inplace          = SAVEPV(proto_perl->Iinplace);
7653     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
7654     PL_perldb           = proto_perl->Iperldb;
7655     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7656
7657     /* magical thingies */
7658     /* XXX time(&PL_basetime) when asked for? */
7659     PL_basetime         = proto_perl->Ibasetime;
7660     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
7661
7662     PL_maxsysfd         = proto_perl->Imaxsysfd;
7663     PL_multiline        = proto_perl->Imultiline;
7664     PL_statusvalue      = proto_perl->Istatusvalue;
7665 #ifdef VMS
7666     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
7667 #endif
7668
7669     /* shortcuts to various I/O objects */
7670     PL_stdingv          = gv_dup(proto_perl->Istdingv);
7671     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
7672     PL_defgv            = gv_dup(proto_perl->Idefgv);
7673     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
7674     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
7675     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
7676
7677     /* shortcuts to regexp stuff */
7678     PL_replgv           = gv_dup(proto_perl->Ireplgv);
7679
7680     /* shortcuts to misc objects */
7681     PL_errgv            = gv_dup(proto_perl->Ierrgv);
7682
7683     /* shortcuts to debugging objects */
7684     PL_DBgv             = gv_dup(proto_perl->IDBgv);
7685     PL_DBline           = gv_dup(proto_perl->IDBline);
7686     PL_DBsub            = gv_dup(proto_perl->IDBsub);
7687     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
7688     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
7689     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
7690     PL_lineary          = av_dup(proto_perl->Ilineary);
7691     PL_dbargs           = av_dup(proto_perl->Idbargs);
7692
7693     /* symbol tables */
7694     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
7695     PL_curstash         = hv_dup(proto_perl->Tcurstash);
7696     PL_debstash         = hv_dup(proto_perl->Idebstash);
7697     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
7698     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
7699
7700     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
7701     PL_endav            = av_dup_inc(proto_perl->Iendav);
7702     PL_checkav          = av_dup_inc(proto_perl->Icheckav);
7703     PL_initav           = av_dup_inc(proto_perl->Iinitav);
7704
7705     PL_sub_generation   = proto_perl->Isub_generation;
7706
7707     /* funky return mechanisms */
7708     PL_forkprocess      = proto_perl->Iforkprocess;
7709
7710     /* subprocess state */
7711     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
7712
7713     /* internal state */
7714     PL_tainting         = proto_perl->Itainting;
7715     PL_maxo             = proto_perl->Imaxo;
7716     if (proto_perl->Iop_mask)
7717         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7718     else
7719         PL_op_mask      = Nullch;
7720
7721     /* current interpreter roots */
7722     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
7723     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
7724     PL_main_start       = proto_perl->Imain_start;
7725     PL_eval_root        = proto_perl->Ieval_root;
7726     PL_eval_start       = proto_perl->Ieval_start;
7727
7728     /* runtime control stuff */
7729     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7730     PL_copline          = proto_perl->Icopline;
7731
7732     PL_filemode         = proto_perl->Ifilemode;
7733     PL_lastfd           = proto_perl->Ilastfd;
7734     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
7735     PL_Argv             = NULL;
7736     PL_Cmd              = Nullch;
7737     PL_gensym           = proto_perl->Igensym;
7738     PL_preambled        = proto_perl->Ipreambled;
7739     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
7740     PL_laststatval      = proto_perl->Ilaststatval;
7741     PL_laststype        = proto_perl->Ilaststype;
7742     PL_mess_sv          = Nullsv;
7743
7744     PL_orslen           = proto_perl->Iorslen;
7745     PL_ors              = SAVEPVN(proto_perl->Iors, PL_orslen);
7746     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
7747
7748     /* interpreter atexit processing */
7749     PL_exitlistlen      = proto_perl->Iexitlistlen;
7750     if (PL_exitlistlen) {
7751         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7752         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7753     }
7754     else
7755         PL_exitlist     = (PerlExitListEntry*)NULL;
7756     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
7757
7758     PL_profiledata      = NULL;
7759     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
7760     /* PL_rsfp_filters entries have fake IoDIRP() */
7761     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
7762
7763     PL_compcv                   = cv_dup(proto_perl->Icompcv);
7764     PL_comppad                  = av_dup(proto_perl->Icomppad);
7765     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
7766     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
7767     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
7768     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
7769                                                         proto_perl->Tcurpad);
7770
7771 #ifdef HAVE_INTERP_INTERN
7772     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7773 #endif
7774
7775     /* more statics moved here */
7776     PL_generation       = proto_perl->Igeneration;
7777     PL_DBcv             = cv_dup(proto_perl->IDBcv);
7778
7779     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
7780     PL_in_clean_all     = proto_perl->Iin_clean_all;
7781
7782     PL_uid              = proto_perl->Iuid;
7783     PL_euid             = proto_perl->Ieuid;
7784     PL_gid              = proto_perl->Igid;
7785     PL_egid             = proto_perl->Iegid;
7786     PL_nomemok          = proto_perl->Inomemok;
7787     PL_an               = proto_perl->Ian;
7788     PL_cop_seqmax       = proto_perl->Icop_seqmax;
7789     PL_op_seqmax        = proto_perl->Iop_seqmax;
7790     PL_evalseq          = proto_perl->Ievalseq;
7791     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
7792     PL_origalen         = proto_perl->Iorigalen;
7793     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
7794     PL_osname           = SAVEPV(proto_perl->Iosname);
7795     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
7796     PL_sighandlerp      = proto_perl->Isighandlerp;
7797
7798
7799     PL_runops           = proto_perl->Irunops;
7800
7801     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7802
7803 #ifdef CSH
7804     PL_cshlen           = proto_perl->Icshlen;
7805     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7806 #endif
7807
7808     PL_lex_state        = proto_perl->Ilex_state;
7809     PL_lex_defer        = proto_perl->Ilex_defer;
7810     PL_lex_expect       = proto_perl->Ilex_expect;
7811     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
7812     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
7813     PL_lex_starts       = proto_perl->Ilex_starts;
7814     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
7815     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
7816     PL_lex_op           = proto_perl->Ilex_op;
7817     PL_lex_inpat        = proto_perl->Ilex_inpat;
7818     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
7819     PL_lex_brackets     = proto_perl->Ilex_brackets;
7820     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7821     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
7822     PL_lex_casemods     = proto_perl->Ilex_casemods;
7823     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7824     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
7825
7826     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7827     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7828     PL_nexttoke         = proto_perl->Inexttoke;
7829
7830     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
7831     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7832     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7833     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7834     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7835     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7836     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7837     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7838     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7839     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7840     PL_pending_ident    = proto_perl->Ipending_ident;
7841     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
7842
7843     PL_expect           = proto_perl->Iexpect;
7844
7845     PL_multi_start      = proto_perl->Imulti_start;
7846     PL_multi_end        = proto_perl->Imulti_end;
7847     PL_multi_open       = proto_perl->Imulti_open;
7848     PL_multi_close      = proto_perl->Imulti_close;
7849
7850     PL_error_count      = proto_perl->Ierror_count;
7851     PL_subline          = proto_perl->Isubline;
7852     PL_subname          = sv_dup_inc(proto_perl->Isubname);
7853
7854     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
7855     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
7856     PL_padix                    = proto_perl->Ipadix;
7857     PL_padix_floor              = proto_perl->Ipadix_floor;
7858     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
7859
7860     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7861     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7862     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7863     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7864     PL_last_lop_op      = proto_perl->Ilast_lop_op;
7865     PL_in_my            = proto_perl->Iin_my;
7866     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
7867 #ifdef FCRYPT
7868     PL_cryptseen        = proto_perl->Icryptseen;
7869 #endif
7870
7871     PL_hints            = proto_perl->Ihints;
7872
7873     PL_amagic_generation        = proto_perl->Iamagic_generation;
7874
7875 #ifdef USE_LOCALE_COLLATE
7876     PL_collation_ix     = proto_perl->Icollation_ix;
7877     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
7878     PL_collation_standard       = proto_perl->Icollation_standard;
7879     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
7880     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
7881 #endif /* USE_LOCALE_COLLATE */
7882
7883 #ifdef USE_LOCALE_NUMERIC
7884     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
7885     PL_numeric_standard = proto_perl->Inumeric_standard;
7886     PL_numeric_local    = proto_perl->Inumeric_local;
7887     PL_numeric_radix    = proto_perl->Inumeric_radix;
7888 #endif /* !USE_LOCALE_NUMERIC */
7889
7890     /* utf8 character classes */
7891     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
7892     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
7893     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
7894     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
7895     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
7896     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
7897     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
7898     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
7899     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
7900     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
7901     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
7902     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
7903     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
7904     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
7905     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
7906     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
7907     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
7908
7909     /* swatch cache */
7910     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
7911     PL_last_swash_klen  = 0;
7912     PL_last_swash_key[0]= '\0';
7913     PL_last_swash_tmps  = (U8*)NULL;
7914     PL_last_swash_slen  = 0;
7915
7916     /* perly.c globals */
7917     PL_yydebug          = proto_perl->Iyydebug;
7918     PL_yynerrs          = proto_perl->Iyynerrs;
7919     PL_yyerrflag        = proto_perl->Iyyerrflag;
7920     PL_yychar           = proto_perl->Iyychar;
7921     PL_yyval            = proto_perl->Iyyval;
7922     PL_yylval           = proto_perl->Iyylval;
7923
7924     PL_glob_index       = proto_perl->Iglob_index;
7925     PL_srand_called     = proto_perl->Isrand_called;
7926     PL_uudmap['M']      = 0;            /* reinits on demand */
7927     PL_bitcount         = Nullch;       /* reinits on demand */
7928
7929     if (proto_perl->Ipsig_ptr) {
7930         int sig_num[] = { SIG_NUM };
7931         Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7932         Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7933         for (i = 1; PL_sig_name[i]; i++) {
7934             PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7935             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7936         }
7937     }
7938     else {
7939         PL_psig_ptr     = (SV**)NULL;
7940         PL_psig_name    = (SV**)NULL;
7941     }
7942
7943     /* thrdvar.h stuff */
7944
7945     if (flags & 1) {
7946         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7947         PL_tmps_ix              = proto_perl->Ttmps_ix;
7948         PL_tmps_max             = proto_perl->Ttmps_max;
7949         PL_tmps_floor           = proto_perl->Ttmps_floor;
7950         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7951         i = 0;
7952         while (i <= PL_tmps_ix) {
7953             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7954             ++i;
7955         }
7956
7957         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7958         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7959         Newz(54, PL_markstack, i, I32);
7960         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
7961                                                   - proto_perl->Tmarkstack);
7962         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
7963                                                   - proto_perl->Tmarkstack);
7964         Copy(proto_perl->Tmarkstack, PL_markstack,
7965              PL_markstack_ptr - PL_markstack + 1, I32);
7966
7967         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7968          * NOTE: unlike the others! */
7969         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
7970         PL_scopestack_max       = proto_perl->Tscopestack_max;
7971         Newz(54, PL_scopestack, PL_scopestack_max, I32);
7972         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7973
7974         /* next push_return() sets PL_retstack[PL_retstack_ix]
7975          * NOTE: unlike the others! */
7976         PL_retstack_ix          = proto_perl->Tretstack_ix;
7977         PL_retstack_max         = proto_perl->Tretstack_max;
7978         Newz(54, PL_retstack, PL_retstack_max, OP*);
7979         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7980
7981         /* NOTE: si_dup() looks at PL_markstack */
7982         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
7983
7984         /* PL_curstack          = PL_curstackinfo->si_stack; */
7985         PL_curstack             = av_dup(proto_perl->Tcurstack);
7986         PL_mainstack            = av_dup(proto_perl->Tmainstack);
7987
7988         /* next PUSHs() etc. set *(PL_stack_sp+1) */
7989         PL_stack_base           = AvARRAY(PL_curstack);
7990         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
7991                                                    - proto_perl->Tstack_base);
7992         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
7993
7994         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7995          * NOTE: unlike the others! */
7996         PL_savestack_ix         = proto_perl->Tsavestack_ix;
7997         PL_savestack_max        = proto_perl->Tsavestack_max;
7998         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7999         PL_savestack            = ss_dup(proto_perl);
8000     }
8001     else {
8002         init_stacks();
8003         ENTER;                  /* perl_destruct() wants to LEAVE; */
8004     }
8005
8006     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
8007     PL_top_env          = &PL_start_env;
8008
8009     PL_op               = proto_perl->Top;
8010
8011     PL_Sv               = Nullsv;
8012     PL_Xpv              = (XPV*)NULL;
8013     PL_na               = proto_perl->Tna;
8014
8015     PL_statbuf          = proto_perl->Tstatbuf;
8016     PL_statcache        = proto_perl->Tstatcache;
8017     PL_statgv           = gv_dup(proto_perl->Tstatgv);
8018     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
8019 #ifdef HAS_TIMES
8020     PL_timesbuf         = proto_perl->Ttimesbuf;
8021 #endif
8022
8023     PL_tainted          = proto_perl->Ttainted;
8024     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
8025     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
8026     PL_rs               = sv_dup_inc(proto_perl->Trs);
8027     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
8028     PL_ofslen           = proto_perl->Tofslen;
8029     PL_ofs              = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8030     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
8031     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
8032     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
8033     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
8034     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
8035
8036     PL_restartop        = proto_perl->Trestartop;
8037     PL_in_eval          = proto_perl->Tin_eval;
8038     PL_delaymagic       = proto_perl->Tdelaymagic;
8039     PL_dirty            = proto_perl->Tdirty;
8040     PL_localizing       = proto_perl->Tlocalizing;
8041
8042 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8043     PL_protect          = proto_perl->Tprotect;
8044 #endif
8045     PL_errors           = sv_dup_inc(proto_perl->Terrors);
8046     PL_av_fetch_sv      = Nullsv;
8047     PL_hv_fetch_sv      = Nullsv;
8048     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
8049     PL_modcount         = proto_perl->Tmodcount;
8050     PL_lastgotoprobe    = Nullop;
8051     PL_dumpindent       = proto_perl->Tdumpindent;
8052
8053     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8054     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
8055     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
8056     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
8057     PL_sortcxix         = proto_perl->Tsortcxix;
8058     PL_efloatbuf        = Nullch;               /* reinits on demand */
8059     PL_efloatsize       = 0;                    /* reinits on demand */
8060
8061     /* regex stuff */
8062
8063     PL_screamfirst      = NULL;
8064     PL_screamnext       = NULL;
8065     PL_maxscream        = -1;                   /* reinits on demand */
8066     PL_lastscream       = Nullsv;
8067
8068     PL_watchaddr        = NULL;
8069     PL_watchok          = Nullch;
8070
8071     PL_regdummy         = proto_perl->Tregdummy;
8072     PL_regcomp_parse    = Nullch;
8073     PL_regxend          = Nullch;
8074     PL_regcode          = (regnode*)NULL;
8075     PL_regnaughty       = 0;
8076     PL_regsawback       = 0;
8077     PL_regprecomp       = Nullch;
8078     PL_regnpar          = 0;
8079     PL_regsize          = 0;
8080     PL_regflags         = 0;
8081     PL_regseen          = 0;
8082     PL_seen_zerolen     = 0;
8083     PL_seen_evals       = 0;
8084     PL_regcomp_rx       = (regexp*)NULL;
8085     PL_extralen         = 0;
8086     PL_colorset         = 0;            /* reinits PL_colors[] */
8087     /*PL_colors[6]      = {0,0,0,0,0,0};*/
8088     PL_reg_whilem_seen  = 0;
8089     PL_reginput         = Nullch;
8090     PL_regbol           = Nullch;
8091     PL_regeol           = Nullch;
8092     PL_regstartp        = (I32*)NULL;
8093     PL_regendp          = (I32*)NULL;
8094     PL_reglastparen     = (U32*)NULL;
8095     PL_regtill          = Nullch;
8096     PL_regprev          = '\n';
8097     PL_reg_start_tmp    = (char**)NULL;
8098     PL_reg_start_tmpl   = 0;
8099     PL_regdata          = (struct reg_data*)NULL;
8100     PL_bostr            = Nullch;
8101     PL_reg_flags        = 0;
8102     PL_reg_eval_set     = 0;
8103     PL_regnarrate       = 0;
8104     PL_regprogram       = (regnode*)NULL;
8105     PL_regindent        = 0;
8106     PL_regcc            = (CURCUR*)NULL;
8107     PL_reg_call_cc      = (struct re_cc_state*)NULL;
8108     PL_reg_re           = (regexp*)NULL;
8109     PL_reg_ganch        = Nullch;
8110     PL_reg_sv           = Nullsv;
8111     PL_reg_magic        = (MAGIC*)NULL;
8112     PL_reg_oldpos       = 0;
8113     PL_reg_oldcurpm     = (PMOP*)NULL;
8114     PL_reg_curpm        = (PMOP*)NULL;
8115     PL_reg_oldsaved     = Nullch;
8116     PL_reg_oldsavedlen  = 0;
8117     PL_reg_maxiter      = 0;
8118     PL_reg_leftiter     = 0;
8119     PL_reg_poscache     = Nullch;
8120     PL_reg_poscache_size= 0;
8121
8122     /* RE engine - function pointers */
8123     PL_regcompp         = proto_perl->Tregcompp;
8124     PL_regexecp         = proto_perl->Tregexecp;
8125     PL_regint_start     = proto_perl->Tregint_start;
8126     PL_regint_string    = proto_perl->Tregint_string;
8127     PL_regfree          = proto_perl->Tregfree;
8128
8129     PL_reginterp_cnt    = 0;
8130     PL_reg_starttry     = 0;
8131
8132 #ifdef PERL_OBJECT
8133     return (PerlInterpreter*)pPerl;
8134 #else
8135     return my_perl;
8136 #endif
8137 }
8138
8139 #else   /* !USE_ITHREADS */
8140
8141 #ifdef PERL_OBJECT
8142 #include "XSUB.h"
8143 #endif
8144
8145 #endif /* USE_ITHREADS */
8146
8147 static void
8148 do_report_used(pTHXo_ SV *sv)
8149 {
8150     if (SvTYPE(sv) != SVTYPEMASK) {
8151         PerlIO_printf(Perl_debug_log, "****\n");
8152         sv_dump(sv);
8153     }
8154 }
8155
8156 static void
8157 do_clean_objs(pTHXo_ SV *sv)
8158 {
8159     SV* rv;
8160
8161     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8162         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8163         SvROK_off(sv);
8164         SvRV(sv) = 0;
8165         SvREFCNT_dec(rv);
8166     }
8167
8168     /* XXX Might want to check arrays, etc. */
8169 }
8170
8171 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8172 static void
8173 do_clean_named_objs(pTHXo_ SV *sv)
8174 {
8175     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8176         if ( SvOBJECT(GvSV(sv)) ||
8177              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8178              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8179              (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8180              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8181         {
8182             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8183             SvREFCNT_dec(sv);
8184         }
8185     }
8186 }
8187 #endif
8188
8189 static void
8190 do_clean_all(pTHXo_ SV *sv)
8191 {
8192     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8193     SvFLAGS(sv) |= SVf_BREAK;
8194     SvREFCNT_dec(sv);
8195 }
8196