sv.c

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