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