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