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
2778             SvTEMP_off(dstr);
2779             (void)SvOK_off(sstr);               /* NOTE: nukes most SvFLAGS on sstr */
2780             SvPV_set(sstr, Nullch);
2781             SvLEN_set(sstr, 0);
2782             SvCUR_set(sstr, 0);
2783             SvTEMP_off(sstr);
2784         }
2785         else {                                  /* have to copy actual string */
2786             STRLEN len = SvCUR(sstr);
2787
2788             SvGROW(dstr, len + 1);              /* inlined from sv_setpvn */
2789             Move(SvPVX(sstr),SvPVX(dstr),len,char);
2790             SvCUR_set(dstr, len);
2791             *SvEND(dstr) = '\0';
2792             (void)SvPOK_only(dstr);
2793         }
2794         if ((sflags & SVf_UTF8) && !IN_BYTE)
2795             SvUTF8_on(dstr);
2796         /*SUPPRESS 560*/
2797         if (sflags & SVp_NOK) {
2798             SvNOK_on(dstr);
2799             SvNVX(dstr) = SvNVX(sstr);
2800         }
2801         if (sflags & SVp_IOK) {
2802             (void)SvIOK_on(dstr);
2803             SvIVX(dstr) = SvIVX(sstr);
2804             if (sflags & SVf_IVisUV)
2805                 SvIsUV_on(dstr);
2806         }
2807     }
2808     else if (sflags & SVp_NOK) {
2809         SvNVX(dstr) = SvNVX(sstr);
2810         (void)SvNOK_only(dstr);
2811         if (sflags & SVf_IOK) {
2812             (void)SvIOK_on(dstr);
2813             SvIVX(dstr) = SvIVX(sstr);
2814             /* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
2815             if (sflags & SVf_IVisUV)
2816                 SvIsUV_on(dstr);
2817         }
2818     }
2819     else if (sflags & SVp_IOK) {
2820         (void)SvIOK_only(dstr);
2821         SvIVX(dstr) = SvIVX(sstr);
2822         if (sflags & SVf_IVisUV)
2823             SvIsUV_on(dstr);
2824     }
2825     else {
2826         if (dtype == SVt_PVGV) {
2827             if (ckWARN(WARN_MISC))
2828                 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2829         }
2830         else
2831             (void)SvOK_off(dstr);
2832     }
2833     SvTAINT(dstr);
2834 }
2835
2836 /*
2837 =for apidoc sv_setsv_mg
2838
2839 Like C<sv_setsv>, but also handles 'set' magic.
2840
2841 =cut
2842 */
2843
2844 void
2845 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2846 {
2847     sv_setsv(dstr,sstr);
2848     SvSETMAGIC(dstr);
2849 }
2850
2851 /*
2852 =for apidoc sv_setpvn
2853
2854 Copies a string into an SV.  The C<len> parameter indicates the number of
2855 bytes to be copied.  Does not handle 'set' magic.  See C<sv_setpvn_mg>.
2856
2857 =cut
2858 */
2859
2860 void
2861 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2862 {
2863     register char *dptr;
2864     assert(len >= 0);  /* STRLEN is probably unsigned, so this may
2865                           elicit a warning, but it won't hurt. */
2866     SV_CHECK_THINKFIRST(sv);
2867     if (!ptr) {
2868         (void)SvOK_off(sv);
2869         return;
2870     }
2871     (void)SvUPGRADE(sv, SVt_PV);
2872
2873     SvGROW(sv, len + 1);
2874     dptr = SvPVX(sv);
2875     Move(ptr,dptr,len,char);
2876     dptr[len] = '\0';
2877     SvCUR_set(sv, len);
2878     (void)SvPOK_only(sv);               /* validate pointer */
2879     SvTAINT(sv);
2880 }
2881
2882 /*
2883 =for apidoc sv_setpvn_mg
2884
2885 Like C<sv_setpvn>, but also handles 'set' magic.
2886
2887 =cut
2888 */
2889
2890 void
2891 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2892 {
2893     sv_setpvn(sv,ptr,len);
2894     SvSETMAGIC(sv);
2895 }
2896
2897 /*
2898 =for apidoc sv_setpv
2899
2900 Copies a string into an SV.  The string must be null-terminated.  Does not
2901 handle 'set' magic.  See C<sv_setpv_mg>.
2902
2903 =cut
2904 */
2905
2906 void
2907 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2908 {
2909     register STRLEN len;
2910
2911     SV_CHECK_THINKFIRST(sv);
2912     if (!ptr) {
2913         (void)SvOK_off(sv);
2914         return;
2915     }
2916     len = strlen(ptr);
2917     (void)SvUPGRADE(sv, SVt_PV);
2918
2919     SvGROW(sv, len + 1);
2920     Move(ptr,SvPVX(sv),len+1,char);
2921     SvCUR_set(sv, len);
2922     (void)SvPOK_only(sv);               /* validate pointer */
2923     SvTAINT(sv);
2924 }
2925
2926 /*
2927 =for apidoc sv_setpv_mg
2928
2929 Like C<sv_setpv>, but also handles 'set' magic.
2930
2931 =cut
2932 */
2933
2934 void
2935 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2936 {
2937     sv_setpv(sv,ptr);
2938     SvSETMAGIC(sv);
2939 }
2940
2941 /*
2942 =for apidoc sv_usepvn
2943
2944 Tells an SV to use C<ptr> to find its string value.  Normally the string is
2945 stored inside the SV but sv_usepvn allows the SV to use an outside string.
2946 The C<ptr> should point to memory that was allocated by C<malloc>.  The
2947 string length, C<len>, must be supplied.  This function will realloc the
2948 memory pointed to by C<ptr>, so that pointer should not be freed or used by
2949 the programmer after giving it to sv_usepvn.  Does not handle 'set' magic.
2950 See C<sv_usepvn_mg>.
2951
2952 =cut
2953 */
2954
2955 void
2956 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2957 {
2958     SV_CHECK_THINKFIRST(sv);
2959     (void)SvUPGRADE(sv, SVt_PV);
2960     if (!ptr) {
2961         (void)SvOK_off(sv);
2962         return;
2963     }
2964     (void)SvOOK_off(sv);
2965     if (SvPVX(sv) && SvLEN(sv))
2966         Safefree(SvPVX(sv));
2967     Renew(ptr, len+1, char);
2968     SvPVX(sv) = ptr;
2969     SvCUR_set(sv, len);
2970     SvLEN_set(sv, len+1);
2971     *SvEND(sv) = '\0';
2972     (void)SvPOK_only(sv);               /* validate pointer */
2973     SvTAINT(sv);
2974 }
2975
2976 /*
2977 =for apidoc sv_usepvn_mg
2978
2979 Like C<sv_usepvn>, but also handles 'set' magic.
2980
2981 =cut
2982 */
2983
2984 void
2985 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2986 {
2987     sv_usepvn(sv,ptr,len);
2988     SvSETMAGIC(sv);
2989 }
2990
2991 void
2992 Perl_sv_force_normal(pTHX_ register SV *sv)
2993 {
2994     if (SvREADONLY(sv)) {
2995         dTHR;
2996         if (PL_curcop != &PL_compiling)
2997             Perl_croak(aTHX_ PL_no_modify);
2998     }
2999     if (SvROK(sv))
3000         sv_unref(sv);
3001     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3002         sv_unglob(sv);
3003 }
3004
3005 /*
3006 =for apidoc sv_chop
3007
3008 Efficient removal of characters from the beginning of the string buffer.
3009 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3010 the string buffer.  The C<ptr> becomes the first character of the adjusted
3011 string.
3012
3013 =cut
3014 */
3015
3016 void
3017 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3018
3019
3020 {
3021     register STRLEN delta;
3022
3023     if (!ptr || !SvPOKp(sv))
3024         return;
3025     SV_CHECK_THINKFIRST(sv);
3026     if (SvTYPE(sv) < SVt_PVIV)
3027         sv_upgrade(sv,SVt_PVIV);
3028
3029     if (!SvOOK(sv)) {
3030         if (!SvLEN(sv)) { /* make copy of shared string */
3031             char *pvx = SvPVX(sv);
3032             STRLEN len = SvCUR(sv);
3033             SvGROW(sv, len + 1);
3034             Move(pvx,SvPVX(sv),len,char);
3035             *SvEND(sv) = '\0';
3036         }
3037         SvIVX(sv) = 0;
3038         SvFLAGS(sv) |= SVf_OOK;
3039     }
3040     SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3041     delta = ptr - SvPVX(sv);
3042     SvLEN(sv) -= delta;
3043     SvCUR(sv) -= delta;
3044     SvPVX(sv) += delta;
3045     SvIVX(sv) += delta;
3046 }
3047
3048 /*
3049 =for apidoc sv_catpvn
3050
3051 Concatenates the string onto the end of the string which is in the SV.  The
3052 C<len> indicates number of bytes to copy.  Handles 'get' magic, but not
3053 'set' magic.  See C<sv_catpvn_mg>.
3054
3055 =cut
3056 */
3057
3058 void
3059 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3060 {
3061     STRLEN tlen;
3062     char *junk;
3063
3064     junk = SvPV_force(sv, tlen);
3065     SvGROW(sv, tlen + len + 1);
3066     if (ptr == junk)
3067         ptr = SvPVX(sv);
3068     Move(ptr,SvPVX(sv)+tlen,len,char);
3069     SvCUR(sv) += len;
3070     *SvEND(sv) = '\0';
3071     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3072     SvTAINT(sv);
3073 }
3074
3075 /*
3076 =for apidoc sv_catpvn_mg
3077
3078 Like C<sv_catpvn>, but also handles 'set' magic.
3079
3080 =cut
3081 */
3082
3083 void
3084 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3085 {
3086     sv_catpvn(sv,ptr,len);
3087     SvSETMAGIC(sv);
3088 }
3089
3090 /*
3091 =for apidoc sv_catsv
3092
3093 Concatenates the string from SV C<ssv> onto the end of the string in SV
3094 C<dsv>.  Handles 'get' magic, but not 'set' magic.  See C<sv_catsv_mg>.
3095
3096 =cut
3097 */
3098
3099 void
3100 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3101 {
3102     char *s;
3103     STRLEN len;
3104     if (!sstr)
3105         return;
3106     if ((s = SvPV(sstr, len))) {
3107         if (SvUTF8(sstr))
3108             sv_utf8_upgrade(dstr);
3109         sv_catpvn(dstr,s,len);
3110         if (SvUTF8(sstr))
3111             SvUTF8_on(dstr);
3112     }
3113 }
3114
3115 /*
3116 =for apidoc sv_catsv_mg
3117
3118 Like C<sv_catsv>, but also handles 'set' magic.
3119
3120 =cut
3121 */
3122
3123 void
3124 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3125 {
3126     sv_catsv(dstr,sstr);
3127     SvSETMAGIC(dstr);
3128 }
3129
3130 /*
3131 =for apidoc sv_catpv
3132
3133 Concatenates the string onto the end of the string which is in the SV.
3134 Handles 'get' magic, but not 'set' magic.  See C<sv_catpv_mg>.
3135
3136 =cut
3137 */
3138
3139 void
3140 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3141 {
3142     register STRLEN len;
3143     STRLEN tlen;
3144     char *junk;
3145
3146     if (!ptr)
3147         return;
3148     junk = SvPV_force(sv, tlen);
3149     len = strlen(ptr);
3150     SvGROW(sv, tlen + len + 1);
3151     if (ptr == junk)
3152         ptr = SvPVX(sv);
3153     Move(ptr,SvPVX(sv)+tlen,len+1,char);
3154     SvCUR(sv) += len;
3155     (void)SvPOK_only_UTF8(sv);          /* validate pointer */
3156     SvTAINT(sv);
3157 }
3158
3159 /*
3160 =for apidoc sv_catpv_mg
3161
3162 Like C<sv_catpv>, but also handles 'set' magic.
3163
3164 =cut
3165 */
3166
3167 void
3168 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3169 {
3170     sv_catpv(sv,ptr);
3171     SvSETMAGIC(sv);
3172 }
3173
3174 SV *
3175 Perl_newSV(pTHX_ STRLEN len)
3176 {
3177     register SV *sv;
3178
3179     new_SV(sv);
3180     if (len) {
3181         sv_upgrade(sv, SVt_PV);
3182         SvGROW(sv, len + 1);
3183     }
3184     return sv;
3185 }
3186
3187 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3188
3189 /*
3190 =for apidoc sv_magic
3191
3192 Adds magic to an SV.
3193
3194 =cut
3195 */
3196
3197 void
3198 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3199 {
3200     MAGIC* mg;
3201
3202     if (SvREADONLY(sv)) {
3203         dTHR;
3204         if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3205             Perl_croak(aTHX_ PL_no_modify);
3206     }
3207     if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3208         if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3209             if (how == 't')
3210                 mg->mg_len |= 1;
3211             return;
3212         }
3213     }
3214     else {
3215         (void)SvUPGRADE(sv, SVt_PVMG);
3216     }
3217     Newz(702,mg, 1, MAGIC);
3218     mg->mg_moremagic = SvMAGIC(sv);
3219
3220     SvMAGIC(sv) = mg;
3221     if (!obj || obj == sv || how == '#' || how == 'r')
3222         mg->mg_obj = obj;
3223     else {
3224         dTHR;
3225         mg->mg_obj = SvREFCNT_inc(obj);
3226         mg->mg_flags |= MGf_REFCOUNTED;
3227     }
3228     mg->mg_type = how;
3229     mg->mg_len = namlen;
3230     if (name)
3231         if (namlen >= 0)
3232             mg->mg_ptr = savepvn(name, namlen);
3233         else if (namlen == HEf_SVKEY)
3234             mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3235
3236     switch (how) {
3237     case 0:
3238         mg->mg_virtual = &PL_vtbl_sv;
3239         break;
3240     case 'A':
3241         mg->mg_virtual = &PL_vtbl_amagic;
3242         break;
3243     case 'a':
3244         mg->mg_virtual = &PL_vtbl_amagicelem;
3245         break;
3246     case 'c':
3247         mg->mg_virtual = 0;
3248         break;
3249     case 'B':
3250         mg->mg_virtual = &PL_vtbl_bm;
3251         break;
3252     case 'D':
3253         mg->mg_virtual = &PL_vtbl_regdata;
3254         break;
3255     case 'd':
3256         mg->mg_virtual = &PL_vtbl_regdatum;
3257         break;
3258     case 'E':
3259         mg->mg_virtual = &PL_vtbl_env;
3260         break;
3261     case 'f':
3262         mg->mg_virtual = &PL_vtbl_fm;
3263         break;
3264     case 'e':
3265         mg->mg_virtual = &PL_vtbl_envelem;
3266         break;
3267     case 'g':
3268         mg->mg_virtual = &PL_vtbl_mglob;
3269         break;
3270     case 'I':
3271         mg->mg_virtual = &PL_vtbl_isa;
3272         break;
3273     case 'i':
3274         mg->mg_virtual = &PL_vtbl_isaelem;
3275         break;
3276     case 'k':
3277         mg->mg_virtual = &PL_vtbl_nkeys;
3278         break;
3279     case 'L':
3280         SvRMAGICAL_on(sv);
3281         mg->mg_virtual = 0;
3282         break;
3283     case 'l':
3284         mg->mg_virtual = &PL_vtbl_dbline;
3285         break;
3286 #ifdef USE_THREADS
3287     case 'm':
3288         mg->mg_virtual = &PL_vtbl_mutex;
3289         break;
3290 #endif /* USE_THREADS */
3291 #ifdef USE_LOCALE_COLLATE
3292     case 'o':
3293         mg->mg_virtual = &PL_vtbl_collxfrm;
3294         break;
3295 #endif /* USE_LOCALE_COLLATE */
3296     case 'P':
3297         mg->mg_virtual = &PL_vtbl_pack;
3298         break;
3299     case 'p':
3300     case 'q':
3301         mg->mg_virtual = &PL_vtbl_packelem;
3302         break;
3303     case 'r':
3304         mg->mg_virtual = &PL_vtbl_regexp;
3305         break;
3306     case 'S':
3307         mg->mg_virtual = &PL_vtbl_sig;
3308         break;
3309     case 's':
3310         mg->mg_virtual = &PL_vtbl_sigelem;
3311         break;
3312     case 't':
3313         mg->mg_virtual = &PL_vtbl_taint;
3314         mg->mg_len = 1;
3315         break;
3316     case 'U':
3317         mg->mg_virtual = &PL_vtbl_uvar;
3318         break;
3319     case 'v':
3320         mg->mg_virtual = &PL_vtbl_vec;
3321         break;
3322     case 'x':
3323         mg->mg_virtual = &PL_vtbl_substr;
3324         break;
3325     case 'y':
3326         mg->mg_virtual = &PL_vtbl_defelem;
3327         break;
3328     case '*':
3329         mg->mg_virtual = &PL_vtbl_glob;
3330         break;
3331     case '#':
3332         mg->mg_virtual = &PL_vtbl_arylen;
3333         break;
3334     case '.':
3335         mg->mg_virtual = &PL_vtbl_pos;
3336         break;
3337     case '<':
3338         mg->mg_virtual = &PL_vtbl_backref;
3339         break;
3340     case '~':   /* Reserved for use by extensions not perl internals.   */
3341         /* Useful for attaching extension internal data to perl vars.   */
3342         /* Note that multiple extensions may clash if magical scalars   */
3343         /* etc holding private data from one are passed to another.     */
3344         SvRMAGICAL_on(sv);
3345         break;
3346     default:
3347         Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3348     }
3349     mg_magical(sv);
3350     if (SvGMAGICAL(sv))
3351         SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3352 }
3353
3354 int
3355 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3356 {
3357     MAGIC* mg;
3358     MAGIC** mgp;
3359     if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3360         return 0;
3361     mgp = &SvMAGIC(sv);
3362     for (mg = *mgp; mg; mg = *mgp) {
3363         if (mg->mg_type == type) {
3364             MGVTBL* vtbl = mg->mg_virtual;
3365             *mgp = mg->mg_moremagic;
3366             if (vtbl && vtbl->svt_free)
3367                 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3368             if (mg->mg_ptr && mg->mg_type != 'g')
3369                 if (mg->mg_len >= 0)
3370                     Safefree(mg->mg_ptr);
3371                 else if (mg->mg_len == HEf_SVKEY)
3372                     SvREFCNT_dec((SV*)mg->mg_ptr);
3373             if (mg->mg_flags & MGf_REFCOUNTED)
3374                 SvREFCNT_dec(mg->mg_obj);
3375             Safefree(mg);
3376         }
3377         else
3378             mgp = &mg->mg_moremagic;
3379     }
3380     if (!SvMAGIC(sv)) {
3381         SvMAGICAL_off(sv);
3382         SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3383     }
3384
3385     return 0;
3386 }
3387
3388 SV *
3389 Perl_sv_rvweaken(pTHX_ SV *sv)
3390 {
3391     SV *tsv;
3392     if (!SvOK(sv))  /* let undefs pass */
3393         return sv;
3394     if (!SvROK(sv))
3395         Perl_croak(aTHX_ "Can't weaken a nonreference");
3396     else if (SvWEAKREF(sv)) {
3397         dTHR;
3398         if (ckWARN(WARN_MISC))
3399             Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3400         return sv;
3401     }
3402     tsv = SvRV(sv);
3403     sv_add_backref(tsv, sv);
3404     SvWEAKREF_on(sv);
3405     SvREFCNT_dec(tsv);
3406     return sv;
3407 }
3408
3409 STATIC void
3410 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3411 {
3412     AV *av;
3413     MAGIC *mg;
3414     if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3415         av = (AV*)mg->mg_obj;
3416     else {
3417         av = newAV();
3418         sv_magic(tsv, (SV*)av, '<', NULL, 0);
3419         SvREFCNT_dec(av);           /* for sv_magic */
3420     }
3421     av_push(av,sv);
3422 }
3423
3424 STATIC void
3425 S_sv_del_backref(pTHX_ SV *sv)
3426 {
3427     AV *av;
3428     SV **svp;
3429     I32 i;
3430     SV *tsv = SvRV(sv);
3431     MAGIC *mg;
3432     if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3433         Perl_croak(aTHX_ "panic: del_backref");
3434     av = (AV *)mg->mg_obj;
3435     svp = AvARRAY(av);
3436     i = AvFILLp(av);
3437     while (i >= 0) {
3438         if (svp[i] == sv) {
3439             svp[i] = &PL_sv_undef; /* XXX */
3440         }
3441         i--;
3442     }
3443 }
3444
3445 /*
3446 =for apidoc sv_insert
3447
3448 Inserts a string at the specified offset/length within the SV. Similar to
3449 the Perl substr() function.
3450
3451 =cut
3452 */
3453
3454 void
3455 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3456 {
3457     register char *big;
3458     register char *mid;
3459     register char *midend;
3460     register char *bigend;
3461     register I32 i;
3462     STRLEN curlen;
3463
3464
3465     if (!bigstr)
3466         Perl_croak(aTHX_ "Can't modify non-existent substring");
3467     SvPV_force(bigstr, curlen);
3468     if (offset + len > curlen) {
3469         SvGROW(bigstr, offset+len+1);
3470         Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3471         SvCUR_set(bigstr, offset+len);
3472     }
3473
3474     SvTAINT(bigstr);
3475     i = littlelen - len;
3476     if (i > 0) {                        /* string might grow */
3477         big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3478         mid = big + offset + len;
3479         midend = bigend = big + SvCUR(bigstr);
3480         bigend += i;
3481         *bigend = '\0';
3482         while (midend > mid)            /* shove everything down */
3483             *--bigend = *--midend;
3484         Move(little,big+offset,littlelen,char);
3485         SvCUR(bigstr) += i;
3486         SvSETMAGIC(bigstr);
3487         return;
3488     }
3489     else if (i == 0) {
3490         Move(little,SvPVX(bigstr)+offset,len,char);
3491         SvSETMAGIC(bigstr);
3492         return;
3493     }
3494
3495     big = SvPVX(bigstr);
3496     mid = big + offset;
3497     midend = mid + len;
3498     bigend = big + SvCUR(bigstr);
3499
3500     if (midend > bigend)
3501         Perl_croak(aTHX_ "panic: sv_insert");
3502
3503     if (mid - big > bigend - midend) {  /* faster to shorten from end */
3504         if (littlelen) {
3505             Move(little, mid, littlelen,char);
3506             mid += littlelen;
3507         }
3508         i = bigend - midend;
3509         if (i > 0) {
3510             Move(midend, mid, i,char);
3511             mid += i;
3512         }
3513         *mid = '\0';
3514         SvCUR_set(bigstr, mid - big);
3515     }
3516     /*SUPPRESS 560*/
3517     else if ((i = mid - big)) { /* faster from front */
3518         midend -= littlelen;
3519         mid = midend;
3520         sv_chop(bigstr,midend-i);
3521         big += i;
3522         while (i--)
3523             *--midend = *--big;
3524         if (littlelen)
3525             Move(little, mid, littlelen,char);
3526     }
3527     else if (littlelen) {
3528         midend -= littlelen;
3529         sv_chop(bigstr,midend);
3530         Move(little,midend,littlelen,char);
3531     }
3532     else {
3533         sv_chop(bigstr,midend);
3534     }
3535     SvSETMAGIC(bigstr);
3536 }
3537
3538 /* make sv point to what nstr did */
3539
3540 void
3541 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3542 {
3543     dTHR;
3544     U32 refcnt = SvREFCNT(sv);
3545     SV_CHECK_THINKFIRST(sv);
3546     if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3547         Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3548     if (SvMAGICAL(sv)) {
3549         if (SvMAGICAL(nsv))
3550             mg_free(nsv);
3551         else
3552             sv_upgrade(nsv, SVt_PVMG);
3553         SvMAGIC(nsv) = SvMAGIC(sv);
3554         SvFLAGS(nsv) |= SvMAGICAL(sv);
3555         SvMAGICAL_off(sv);
3556         SvMAGIC(sv) = 0;
3557     }
3558     SvREFCNT(sv) = 0;
3559     sv_clear(sv);
3560     assert(!SvREFCNT(sv));
3561     StructCopy(nsv,sv,SV);
3562     SvREFCNT(sv) = refcnt;
3563     SvFLAGS(nsv) |= SVTYPEMASK;         /* Mark as freed */
3564     del_SV(nsv);
3565 }
3566
3567 void
3568 Perl_sv_clear(pTHX_ register SV *sv)
3569 {
3570     HV* stash;
3571     assert(sv);
3572     assert(SvREFCNT(sv) == 0);
3573
3574     if (SvOBJECT(sv)) {
3575         dTHR;
3576         if (PL_defstash) {              /* Still have a symbol table? */
3577             djSP;
3578             GV* destructor;
3579             SV tmpref;
3580
3581             Zero(&tmpref, 1, SV);
3582             sv_upgrade(&tmpref, SVt_RV);
3583             SvROK_on(&tmpref);
3584             SvREADONLY_on(&tmpref);     /* DESTROY() could be naughty */
3585             SvREFCNT(&tmpref) = 1;
3586
3587             do {
3588                 stash = SvSTASH(sv);
3589                 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3590                 if (destructor) {
3591                     ENTER;
3592                     PUSHSTACKi(PERLSI_DESTROY);
3593                     SvRV(&tmpref) = SvREFCNT_inc(sv);
3594                     EXTEND(SP, 2);
3595                     PUSHMARK(SP);
3596                     PUSHs(&tmpref);
3597                     PUTBACK;
3598                     call_sv((SV*)GvCV(destructor),
3599                             G_DISCARD|G_EVAL|G_KEEPERR);
3600                     SvREFCNT(sv)--;
3601                     POPSTACK;
3602                     SPAGAIN;
3603                     LEAVE;
3604                 }
3605             } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3606
3607             del_XRV(SvANY(&tmpref));
3608
3609             if (SvREFCNT(sv)) {
3610                 if (PL_in_clean_objs)
3611                     Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3612                           HvNAME(stash));
3613                 /* DESTROY gave object new lease on life */
3614                 return;
3615             }
3616         }
3617
3618         if (SvOBJECT(sv)) {
3619             SvREFCNT_dec(SvSTASH(sv));  /* possibly of changed persuasion */
3620             SvOBJECT_off(sv);   /* Curse the object. */
3621             if (SvTYPE(sv) != SVt_PVIO)
3622                 --PL_sv_objcount;       /* XXX Might want something more general */
3623         }
3624     }
3625     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3626         mg_free(sv);
3627     stash = NULL;
3628     switch (SvTYPE(sv)) {
3629     case SVt_PVIO:
3630         if (IoIFP(sv) &&
3631             IoIFP(sv) != PerlIO_stdin() &&
3632             IoIFP(sv) != PerlIO_stdout() &&
3633             IoIFP(sv) != PerlIO_stderr())
3634         {
3635             io_close((IO*)sv, FALSE);
3636         }
3637         if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3638             PerlDir_close(IoDIRP(sv));
3639         IoDIRP(sv) = (DIR*)NULL;
3640         Safefree(IoTOP_NAME(sv));
3641         Safefree(IoFMT_NAME(sv));
3642         Safefree(IoBOTTOM_NAME(sv));
3643         /* FALL THROUGH */
3644     case SVt_PVBM:
3645         goto freescalar;
3646     case SVt_PVCV:
3647     case SVt_PVFM:
3648         cv_undef((CV*)sv);
3649         goto freescalar;
3650     case SVt_PVHV:
3651         hv_undef((HV*)sv);
3652         break;
3653     case SVt_PVAV:
3654         av_undef((AV*)sv);
3655         break;
3656     case SVt_PVLV:
3657         SvREFCNT_dec(LvTARG(sv));
3658         goto freescalar;
3659     case SVt_PVGV:
3660         gp_free((GV*)sv);
3661         Safefree(GvNAME(sv));
3662         /* cannot decrease stash refcount yet, as we might recursively delete
3663            ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3664            of stash until current sv is completely gone.
3665            -- JohnPC, 27 Mar 1998 */
3666         stash = GvSTASH(sv);
3667         /* FALL THROUGH */
3668     case SVt_PVMG:
3669     case SVt_PVNV:
3670     case SVt_PVIV:
3671       freescalar:
3672         (void)SvOOK_off(sv);
3673         /* FALL THROUGH */
3674     case SVt_PV:
3675     case SVt_RV:
3676         if (SvROK(sv)) {
3677             if (SvWEAKREF(sv))
3678                 sv_del_backref(sv);
3679             else
3680                 SvREFCNT_dec(SvRV(sv));
3681         }
3682         else if (SvPVX(sv) && SvLEN(sv))
3683             Safefree(SvPVX(sv));
3684         break;
3685 /*
3686     case SVt_NV:
3687     case SVt_IV:
3688     case SVt_NULL:
3689         break;
3690 */
3691     }
3692
3693     switch (SvTYPE(sv)) {
3694     case SVt_NULL:
3695         break;
3696     case SVt_IV:
3697         del_XIV(SvANY(sv));
3698         break;
3699     case SVt_NV:
3700         del_XNV(SvANY(sv));
3701         break;
3702     case SVt_RV:
3703         del_XRV(SvANY(sv));
3704         break;
3705     case SVt_PV:
3706         del_XPV(SvANY(sv));
3707         break;
3708     case SVt_PVIV:
3709         del_XPVIV(SvANY(sv));
3710         break;
3711     case SVt_PVNV:
3712         del_XPVNV(SvANY(sv));
3713         break;
3714     case SVt_PVMG:
3715         del_XPVMG(SvANY(sv));
3716         break;
3717     case SVt_PVLV:
3718         del_XPVLV(SvANY(sv));
3719         break;
3720     case SVt_PVAV:
3721         del_XPVAV(SvANY(sv));
3722         break;
3723     case SVt_PVHV:
3724         del_XPVHV(SvANY(sv));
3725         break;
3726     case SVt_PVCV:
3727         del_XPVCV(SvANY(sv));
3728         break;
3729     case SVt_PVGV:
3730         del_XPVGV(SvANY(sv));
3731         /* code duplication for increased performance. */
3732         SvFLAGS(sv) &= SVf_BREAK;
3733         SvFLAGS(sv) |= SVTYPEMASK;
3734         /* decrease refcount of the stash that owns this GV, if any */
3735         if (stash)
3736             SvREFCNT_dec(stash);
3737         return; /* not break, SvFLAGS reset already happened */
3738     case SVt_PVBM:
3739         del_XPVBM(SvANY(sv));
3740         break;
3741     case SVt_PVFM:
3742         del_XPVFM(SvANY(sv));
3743         break;
3744     case SVt_PVIO:
3745         del_XPVIO(SvANY(sv));
3746         break;
3747     }
3748     SvFLAGS(sv) &= SVf_BREAK;
3749     SvFLAGS(sv) |= SVTYPEMASK;
3750 }
3751
3752 SV *
3753 Perl_sv_newref(pTHX_ SV *sv)
3754 {
3755     if (sv)
3756         ATOMIC_INC(SvREFCNT(sv));
3757     return sv;
3758 }
3759
3760 void
3761 Perl_sv_free(pTHX_ SV *sv)
3762 {
3763     dTHR;
3764     int refcount_is_zero;
3765
3766     if (!sv)
3767         return;
3768     if (SvREFCNT(sv) == 0) {
3769         if (SvFLAGS(sv) & SVf_BREAK)
3770             return;
3771         if (PL_in_clean_all) /* All is fair */
3772             return;
3773         if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3774             /* make sure SvREFCNT(sv)==0 happens very seldom */
3775             SvREFCNT(sv) = (~(U32)0)/2;
3776             return;
3777         }
3778         if (ckWARN_d(WARN_INTERNAL))
3779             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3780         return;
3781     }
3782     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3783     if (!refcount_is_zero)
3784         return;
3785 #ifdef DEBUGGING
3786     if (SvTEMP(sv)) {
3787         if (ckWARN_d(WARN_DEBUGGING))
3788             Perl_warner(aTHX_ WARN_DEBUGGING,
3789                         "Attempt to free temp prematurely: SV 0x%"UVxf,
3790                         PTR2UV(sv));
3791         return;
3792     }
3793 #endif
3794     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3795         /* make sure SvREFCNT(sv)==0 happens very seldom */
3796         SvREFCNT(sv) = (~(U32)0)/2;
3797         return;
3798     }
3799     sv_clear(sv);
3800     if (! SvREFCNT(sv))
3801         del_SV(sv);
3802 }
3803
3804 /*
3805 =for apidoc sv_len
3806
3807 Returns the length of the string in the SV.  See also C<SvCUR>.
3808
3809 =cut
3810 */
3811
3812 STRLEN
3813 Perl_sv_len(pTHX_ register SV *sv)
3814 {
3815     char *junk;
3816     STRLEN len;
3817
3818     if (!sv)
3819         return 0;
3820
3821     if (SvGMAGICAL(sv))
3822         len = mg_length(sv);
3823     else
3824         junk = SvPV(sv, len);
3825     return len;
3826 }
3827
3828 STRLEN
3829 Perl_sv_len_utf8(pTHX_ register SV *sv)
3830 {
3831     U8 *s;
3832     U8 *send;
3833     STRLEN len;
3834
3835     if (!sv)
3836         return 0;
3837
3838 #ifdef NOTYET
3839     if (SvGMAGICAL(sv))
3840         len = mg_length(sv);
3841     else
3842 #endif
3843         s = (U8*)SvPV(sv, len);
3844     send = s + len;
3845     len = 0;
3846     while (s < send) {
3847         s += UTF8SKIP(s);
3848         len++;
3849     }
3850     return len;
3851 }
3852
3853 void
3854 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3855 {
3856     U8 *start;
3857     U8 *s;
3858     U8 *send;
3859     I32 uoffset = *offsetp;
3860     STRLEN len;
3861
3862     if (!sv)
3863         return;
3864
3865     start = s = (U8*)SvPV(sv, len);
3866     send = s + len;
3867     while (s < send && uoffset--)
3868         s += UTF8SKIP(s);
3869     if (s >= send)
3870         s = send;
3871     *offsetp = s - start;
3872     if (lenp) {
3873         I32 ulen = *lenp;
3874         start = s;
3875         while (s < send && ulen--)
3876             s += UTF8SKIP(s);
3877         if (s >= send)
3878             s = send;
3879         *lenp = s - start;
3880     }
3881     return;
3882 }
3883
3884 void
3885 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3886 {
3887     U8 *s;
3888     U8 *send;
3889     STRLEN len;
3890
3891     if (!sv)
3892         return;
3893
3894     s = (U8*)SvPV(sv, len);
3895     if (len < *offsetp)
3896         Perl_croak(aTHX_ "panic: bad byte offset");
3897     send = s + *offsetp;
3898     len = 0;
3899     while (s < send) {
3900         s += UTF8SKIP(s);
3901         ++len;
3902     }
3903     if (s != send) {
3904         dTHR;
3905         if (ckWARN_d(WARN_UTF8))
3906             Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3907         --len;
3908     }
3909     *offsetp = len;
3910     return;
3911 }
3912
3913 /*
3914 =for apidoc sv_eq
3915
3916 Returns a boolean indicating whether the strings in the two SVs are
3917 identical.
3918
3919 =cut
3920 */
3921
3922 I32
3923 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3924 {
3925     char *pv1;
3926     STRLEN cur1;
3927     char *pv2;
3928     STRLEN cur2;
3929
3930     if (!str1) {
3931         pv1 = "";
3932         cur1 = 0;
3933     }
3934     else
3935         pv1 = SvPV(str1, cur1);
3936
3937     if (cur1) {
3938         if (!str2)
3939             return 0;
3940         if (SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3941             if (SvUTF8(str1)) {
3942                 sv_utf8_upgrade(str2);
3943             }
3944             else {
3945                 sv_utf8_upgrade(str1);
3946             }
3947         }
3948     }
3949     pv2 = SvPV(str2, cur2);
3950
3951     if (cur1 != cur2)
3952         return 0;
3953
3954     return memEQ(pv1, pv2, cur1);
3955 }
3956
3957 /*
3958 =for apidoc sv_cmp
3959
3960 Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
3961 string in C<sv1> is less than, equal to, or greater than the string in
3962 C<sv2>.
3963
3964 =cut
3965 */
3966
3967 I32
3968 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3969 {
3970     STRLEN cur1, cur2;
3971     char *pv1, *pv2;
3972     I32 retval;
3973
3974     if (str1) {
3975         pv1 = SvPV(str1, cur1);
3976     }
3977     else {
3978         cur1 = 0;
3979     }
3980
3981     if (str2) {
3982         if (SvPOK(str2)) {
3983             if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
3984                 /* must upgrade other to UTF8 first */
3985                 if (SvUTF8(str1)) {
3986                     sv_utf8_upgrade(str2);
3987                 }
3988                 else {
3989                     sv_utf8_upgrade(str1);
3990                     /* refresh pointer and length */
3991                     pv1  = SvPVX(str1);
3992                     cur1 = SvCUR(str1);
3993                 }
3994             }
3995             pv2  = SvPVX(str2);
3996             cur2 = SvCUR(str2);
3997         }
3998         else {
3999             pv2 = sv_2pv(str2, &cur2);
4000         }
4001     }
4002     else {
4003         cur2 = 0;
4004     }
4005
4006     if (!cur1)
4007         return cur2 ? -1 : 0;
4008
4009     if (!cur2)
4010         return 1;
4011
4012     retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4013
4014     if (retval)
4015         return retval < 0 ? -1 : 1;
4016
4017     if (cur1 == cur2)
4018         return 0;
4019     else
4020         return cur1 < cur2 ? -1 : 1;
4021 }
4022
4023 I32
4024 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4025 {
4026 #ifdef USE_LOCALE_COLLATE
4027
4028     char *pv1, *pv2;
4029     STRLEN len1, len2;
4030     I32 retval;
4031
4032     if (PL_collation_standard)
4033         goto raw_compare;
4034
4035     len1 = 0;
4036     pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4037     len2 = 0;
4038     pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4039
4040     if (!pv1 || !len1) {
4041         if (pv2 && len2)
4042             return -1;
4043         else
4044             goto raw_compare;
4045     }
4046     else {
4047         if (!pv2 || !len2)
4048             return 1;
4049     }
4050
4051     retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4052
4053     if (retval)
4054         return retval < 0 ? -1 : 1;
4055
4056     /*
4057      * When the result of collation is equality, that doesn't mean
4058      * that there are no differences -- some locales exclude some
4059      * characters from consideration.  So to avoid false equalities,
4060      * we use the raw string as a tiebreaker.
4061      */
4062
4063   raw_compare:
4064     /* FALL THROUGH */
4065
4066 #endif /* USE_LOCALE_COLLATE */
4067
4068     return sv_cmp(sv1, sv2);
4069 }
4070
4071 #ifdef USE_LOCALE_COLLATE
4072 /*
4073  * Any scalar variable may carry an 'o' magic that contains the
4074  * scalar data of the variable transformed to such a format that
4075  * a normal memory comparison can be used to compare the data
4076  * according to the locale settings.
4077  */
4078 char *
4079 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4080 {
4081     MAGIC *mg;
4082
4083     mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4084     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4085         char *s, *xf;
4086         STRLEN len, xlen;
4087
4088         if (mg)
4089             Safefree(mg->mg_ptr);
4090         s = SvPV(sv, len);
4091         if ((xf = mem_collxfrm(s, len, &xlen))) {
4092             if (SvREADONLY(sv)) {
4093                 SAVEFREEPV(xf);
4094                 *nxp = xlen;
4095                 return xf + sizeof(PL_collation_ix);
4096             }
4097             if (! mg) {
4098                 sv_magic(sv, 0, 'o', 0, 0);
4099                 mg = mg_find(sv, 'o');
4100                 assert(mg);
4101             }
4102             mg->mg_ptr = xf;
4103             mg->mg_len = xlen;
4104         }
4105         else {
4106             if (mg) {
4107                 mg->mg_ptr = NULL;
4108                 mg->mg_len = -1;
4109             }
4110         }
4111     }
4112     if (mg && mg->mg_ptr) {
4113         *nxp = mg->mg_len;
4114         return mg->mg_ptr + sizeof(PL_collation_ix);
4115     }
4116     else {
4117         *nxp = 0;
4118         return NULL;
4119     }
4120 }
4121
4122 #endif /* USE_LOCALE_COLLATE */
4123
4124 char *
4125 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4126 {
4127     dTHR;
4128     char *rsptr;
4129     STRLEN rslen;
4130     register STDCHAR rslast;
4131     register STDCHAR *bp;
4132     register I32 cnt;
4133     I32 i;
4134
4135     SV_CHECK_THINKFIRST(sv);
4136     (void)SvUPGRADE(sv, SVt_PV);
4137
4138     SvSCREAM_off(sv);
4139
4140     if (RsSNARF(PL_rs)) {
4141         rsptr = NULL;
4142         rslen = 0;
4143     }
4144     else if (RsRECORD(PL_rs)) {
4145       I32 recsize, bytesread;
4146       char *buffer;
4147
4148       /* Grab the size of the record we're getting */
4149       recsize = SvIV(SvRV(PL_rs));
4150       (void)SvPOK_only(sv);    /* Validate pointer */
4151       buffer = SvGROW(sv, recsize + 1);
4152       /* Go yank in */
4153 #ifdef VMS
4154       /* VMS wants read instead of fread, because fread doesn't respect */
4155       /* RMS record boundaries. This is not necessarily a good thing to be */
4156       /* doing, but we've got no other real choice */
4157       bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4158 #else
4159       bytesread = PerlIO_read(fp, buffer, recsize);
4160 #endif
4161       SvCUR_set(sv, bytesread);
4162       buffer[bytesread] = '\0';
4163       return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4164     }
4165     else if (RsPARA(PL_rs)) {
4166         rsptr = "\n\n";
4167         rslen = 2;
4168     }
4169     else
4170         rsptr = SvPV(PL_rs, rslen);
4171     rslast = rslen ? rsptr[rslen - 1] : '\0';
4172
4173     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
4174         do {                    /* to make sure file boundaries work right */
4175             if (PerlIO_eof(fp))
4176                 return 0;
4177             i = PerlIO_getc(fp);
4178             if (i != '\n') {
4179                 if (i == -1)
4180                     return 0;
4181                 PerlIO_ungetc(fp,i);
4182                 break;
4183             }
4184         } while (i != EOF);
4185     }
4186
4187     /* See if we know enough about I/O mechanism to cheat it ! */
4188
4189     /* This used to be #ifdef test - it is made run-time test for ease
4190        of abstracting out stdio interface. One call should be cheap
4191        enough here - and may even be a macro allowing compile
4192        time optimization.
4193      */
4194
4195     if (PerlIO_fast_gets(fp)) {
4196
4197     /*
4198      * We're going to steal some values from the stdio struct
4199      * and put EVERYTHING in the innermost loop into registers.
4200      */
4201     register STDCHAR *ptr;
4202     STRLEN bpx;
4203     I32 shortbuffered;
4204
4205 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4206     /* An ungetc()d char is handled separately from the regular
4207      * buffer, so we getc() it back out and stuff it in the buffer.
4208      */
4209     i = PerlIO_getc(fp);
4210     if (i == EOF) return 0;
4211     *(--((*fp)->_ptr)) = (unsigned char) i;
4212     (*fp)->_cnt++;
4213 #endif
4214
4215     /* Here is some breathtakingly efficient cheating */
4216
4217     cnt = PerlIO_get_cnt(fp);                   /* get count into register */
4218     (void)SvPOK_only(sv);               /* validate pointer */
4219     if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4220         if (cnt > 80 && SvLEN(sv) > append) {
4221             shortbuffered = cnt - SvLEN(sv) + append + 1;
4222             cnt -= shortbuffered;
4223         }
4224         else {
4225             shortbuffered = 0;
4226             /* remember that cnt can be negative */
4227             SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4228         }
4229     }
4230     else
4231         shortbuffered = 0;
4232     bp = (STDCHAR*)SvPVX(sv) + append;  /* move these two too to registers */
4233     ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4234     DEBUG_P(PerlIO_printf(Perl_debug_log,
4235         "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4236     DEBUG_P(PerlIO_printf(Perl_debug_log,
4237         "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4238                PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4239                PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4240     for (;;) {
4241       screamer:
4242         if (cnt > 0) {
4243             if (rslen) {
4244                 while (cnt > 0) {                    /* this     |  eat */
4245                     cnt--;
4246                     if ((*bp++ = *ptr++) == rslast)  /* really   |  dust */
4247                         goto thats_all_folks;        /* screams  |  sed :-) */
4248                 }
4249             }
4250             else {
4251                 Copy(ptr, bp, cnt, char);            /* this     |  eat */
4252                 bp += cnt;                           /* screams  |  dust */
4253                 ptr += cnt;                          /* louder   |  sed :-) */
4254                 cnt = 0;
4255             }
4256         }
4257
4258         if (shortbuffered) {            /* oh well, must extend */
4259             cnt = shortbuffered;
4260             shortbuffered = 0;
4261             bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4262             SvCUR_set(sv, bpx);
4263             SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4264             bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4265             continue;
4266         }
4267
4268         DEBUG_P(PerlIO_printf(Perl_debug_log,
4269                               "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4270                               PTR2UV(ptr),(long)cnt));
4271         PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4272         DEBUG_P(PerlIO_printf(Perl_debug_log,
4273             "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4274             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4275             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4276         /* This used to call 'filbuf' in stdio form, but as that behaves like
4277            getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4278            another abstraction.  */
4279         i   = PerlIO_getc(fp);          /* get more characters */
4280         DEBUG_P(PerlIO_printf(Perl_debug_log,
4281             "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4282             PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4283             PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4284         cnt = PerlIO_get_cnt(fp);
4285         ptr = (STDCHAR*)PerlIO_get_ptr(fp);     /* reregisterize cnt and ptr */
4286         DEBUG_P(PerlIO_printf(Perl_debug_log,
4287             "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4288
4289         if (i == EOF)                   /* all done for ever? */
4290             goto thats_really_all_folks;
4291
4292         bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4293         SvCUR_set(sv, bpx);
4294         SvGROW(sv, bpx + cnt + 2);
4295         bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4296
4297         *bp++ = i;                      /* store character from PerlIO_getc */
4298
4299         if (rslen && (STDCHAR)i == rslast)  /* all done for now? */
4300             goto thats_all_folks;
4301     }
4302
4303 thats_all_folks:
4304     if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4305           memNE((char*)bp - rslen, rsptr, rslen))
4306         goto screamer;                          /* go back to the fray */
4307 thats_really_all_folks:
4308     if (shortbuffered)
4309         cnt += shortbuffered;
4310         DEBUG_P(PerlIO_printf(Perl_debug_log,
4311             "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4312     PerlIO_set_ptrcnt(fp, ptr, cnt);    /* put these back or we're in trouble */
4313     DEBUG_P(PerlIO_printf(Perl_debug_log,
4314         "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4315         PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4316         PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4317     *bp = '\0';
4318     SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv));    /* set length */
4319     DEBUG_P(PerlIO_printf(Perl_debug_log,
4320         "Screamer: done, len=%ld, string=|%.*s|\n",
4321         (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4322     }
4323    else
4324     {
4325 #ifndef EPOC
4326        /*The big, slow, and stupid way */
4327         STDCHAR buf[8192];
4328 #else
4329         /* Need to work around EPOC SDK features          */
4330         /* On WINS: MS VC5 generates calls to _chkstk,    */
4331         /* if a `large' stack frame is allocated          */
4332         /* gcc on MARM does not generate calls like these */
4333         STDCHAR buf[1024];
4334 #endif
4335
4336 screamer2:
4337         if (rslen) {
4338             register STDCHAR *bpe = buf + sizeof(buf);
4339             bp = buf;
4340             while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4341                 ; /* keep reading */
4342             cnt = bp - buf;
4343         }
4344         else {
4345             cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4346             /* Accomodate broken VAXC compiler, which applies U8 cast to
4347              * both args of ?: operator, causing EOF to change into 255
4348              */
4349             if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4350         }
4351
4352         if (append)
4353             sv_catpvn(sv, (char *) buf, cnt);
4354         else
4355             sv_setpvn(sv, (char *) buf, cnt);
4356
4357         if (i != EOF &&                 /* joy */
4358             (!rslen ||
4359              SvCUR(sv) < rslen ||
4360              memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4361         {
4362             append = -1;
4363             /*
4364              * If we're reading from a TTY and we get a short read,
4365              * indicating that the user hit his EOF character, we need
4366              * to notice it now, because if we try to read from the TTY
4367              * again, the EOF condition will disappear.
4368              *
4369              * The comparison of cnt to sizeof(buf) is an optimization
4370              * that prevents unnecessary calls to feof().
4371              *
4372              * - jik 9/25/96
4373              */
4374             if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4375                 goto screamer2;
4376         }
4377     }
4378
4379     if (RsPARA(PL_rs)) {                /* have to do this both before and after */
4380         while (i != EOF) {      /* to make sure file boundaries work right */
4381             i = PerlIO_getc(fp);
4382             if (i != '\n') {
4383                 PerlIO_ungetc(fp,i);
4384                 break;
4385             }
4386         }
4387     }
4388
4389     return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4390 }
4391
4392
4393 /*
4394 =for apidoc sv_inc
4395
4396 Auto-increment of the value in the SV.
4397
4398 =cut
4399 */
4400
4401 void
4402 Perl_sv_inc(pTHX_ register SV *sv)
4403 {
4404     register char *d;
4405     int flags;
4406
4407     if (!sv)
4408         return;
4409     if (SvGMAGICAL(sv))
4410         mg_get(sv);
4411     if (SvTHINKFIRST(sv)) {
4412         if (SvREADONLY(sv)) {
4413             dTHR;
4414             if (PL_curcop != &PL_compiling)
4415                 Perl_croak(aTHX_ PL_no_modify);
4416         }
4417         if (SvROK(sv)) {
4418             IV i;
4419             if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4420                 return;
4421             i = PTR2IV(SvRV(sv));
4422             sv_unref(sv);
4423             sv_setiv(sv, i);
4424         }
4425     }
4426     flags = SvFLAGS(sv);
4427     if (flags & SVp_NOK) {
4428         (void)SvNOK_only(sv);
4429         SvNVX(sv) += 1.0;
4430         return;
4431     }
4432     if (flags & SVp_IOK) {
4433         if (SvIsUV(sv)) {
4434             if (SvUVX(sv) == UV_MAX)
4435                 sv_setnv(sv, (NV)UV_MAX + 1.0);
4436             else
4437                 (void)SvIOK_only_UV(sv);
4438                 ++SvUVX(sv);
4439         } else {
4440             if (SvIVX(sv) == IV_MAX)
4441                 sv_setnv(sv, (NV)IV_MAX + 1.0);
4442             else {
4443                 (void)SvIOK_only(sv);
4444                 ++SvIVX(sv);
4445             }
4446         }
4447         return;
4448     }
4449     if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4450         if ((flags & SVTYPEMASK) < SVt_PVNV)
4451             sv_upgrade(sv, SVt_NV);
4452         SvNVX(sv) = 1.0;
4453         (void)SvNOK_only(sv);
4454         return;
4455     }
4456     d = SvPVX(sv);
4457     while (isALPHA(*d)) d++;
4458     while (isDIGIT(*d)) d++;
4459     if (*d) {
4460         sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);  /* punt */
4461         return;
4462     }
4463     d--;
4464     while (d >= SvPVX(sv)) {
4465         if (isDIGIT(*d)) {
4466             if (++*d <= '9')
4467                 return;
4468             *(d--) = '0';
4469         }
4470         else {
4471 #ifdef EBCDIC
4472             /* MKS: The original code here died if letters weren't consecutive.
4473              * at least it didn't have to worry about non-C locales.  The
4474              * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4475              * arranged in order (although not consecutively) and that only
4476              * [A-Za-z] are accepted by isALPHA in the C locale.
4477              */
4478             if (*d != 'z' && *d != 'Z') {
4479                 do { ++*d; } while (!isALPHA(*d));
4480                 return;
4481             }
4482             *(d--) -= 'z' - 'a';
4483 #else
4484             ++*d;
4485             if (isALPHA(*d))
4486                 return;
4487             *(d--) -= 'z' - 'a' + 1;
4488 #endif
4489         }
4490     }
4491     /* oh,oh, the number grew */
4492     SvGROW(sv, SvCUR(sv) + 2);
4493     SvCUR(sv)++;
4494     for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4495         *d = d[-1];
4496     if (isDIGIT(d[1]))
4497         *d = '1';
4498     else
4499         *d = d[1];
4500 }
4501
4502 /*
4503 =for apidoc sv_dec
4504
4505 Auto-decrement of the value in the SV.
4506
4507 =cut
4508 */
4509
4510 void
4511 Perl_sv_dec(pTHX_ register SV *sv)
4512 {
4513     int flags;
4514
4515     if (!sv)
4516         return;
4517     if (SvGMAGICAL(sv))
4518         mg_get(sv);
4519     if (SvTHINKFIRST(sv)) {
4520         if (SvREADONLY(sv)) {
4521             dTHR;
4522             if (PL_curcop != &PL_compiling)
4523                 Perl_croak(aTHX_ PL_no_modify);
4524         }
4525         if (SvROK(sv)) {
4526             IV i;
4527             if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4528                 return;
4529             i = PTR2IV(SvRV(sv));
4530             sv_unref(sv);
4531             sv_setiv(sv, i);
4532         }
4533     }
4534     flags = SvFLAGS(sv);
4535     if (flags & SVp_NOK) {
4536         SvNVX(sv) -= 1.0;
4537         (void)SvNOK_only(sv);
4538         return;
4539     }
4540     if (flags & SVp_IOK) {
4541         if (SvIsUV(sv)) {
4542             if (SvUVX(sv) == 0) {
4543                 (void)SvIOK_only(sv);
4544                 SvIVX(sv) = -1;
4545             }
4546             else {
4547                 (void)SvIOK_only_UV(sv);
4548                 --SvUVX(sv);
4549             }
4550         } else {
4551             if (SvIVX(sv) == IV_MIN)
4552                 sv_setnv(sv, (NV)IV_MIN - 1.0);
4553             else {
4554                 (void)SvIOK_only(sv);
4555                 --SvIVX(sv);
4556             }
4557         }
4558         return;
4559     }
4560     if (!(flags & SVp_POK)) {
4561         if ((flags & SVTYPEMASK) < SVt_PVNV)
4562             sv_upgrade(sv, SVt_NV);
4563         SvNVX(sv) = -1.0;
4564         (void)SvNOK_only(sv);
4565         return;
4566     }
4567     sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4568 }
4569
4570 /*
4571 =for apidoc sv_mortalcopy
4572
4573 Creates a new SV which is a copy of the original SV.  The new SV is marked
4574 as mortal.
4575
4576 =cut
4577 */
4578
4579 /* Make a string that will exist for the duration of the expression
4580  * evaluation.  Actually, it may have to last longer than that, but
4581  * hopefully we won't free it until it has been assigned to a
4582  * permanent location. */
4583
4584 SV *
4585 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4586 {
4587     dTHR;
4588     register SV *sv;
4589
4590     new_SV(sv);
4591     sv_setsv(sv,oldstr);
4592     EXTEND_MORTAL(1);
4593     PL_tmps_stack[++PL_tmps_ix] = sv;
4594     SvTEMP_on(sv);
4595     return sv;
4596 }
4597
4598 /*
4599 =for apidoc sv_newmortal
4600
4601 Creates a new SV which is mortal.  The reference count of the SV is set to 1.
4602
4603 =cut
4604 */
4605
4606 SV *
4607 Perl_sv_newmortal(pTHX)
4608 {
4609     dTHR;
4610     register SV *sv;
4611
4612     new_SV(sv);
4613     SvFLAGS(sv) = SVs_TEMP;
4614     EXTEND_MORTAL(1);
4615     PL_tmps_stack[++PL_tmps_ix] = sv;
4616     return sv;
4617 }
4618
4619 /*
4620 =for apidoc sv_2mortal
4621
4622 Marks an SV as mortal.  The SV will be destroyed when the current context
4623 ends.
4624
4625 =cut
4626 */
4627
4628 /* same thing without the copying */
4629
4630 SV *
4631 Perl_sv_2mortal(pTHX_ register SV *sv)
4632 {
4633     dTHR;
4634     if (!sv)
4635         return sv;
4636     if (SvREADONLY(sv) && SvIMMORTAL(sv))
4637         return sv;
4638     EXTEND_MORTAL(1);
4639     PL_tmps_stack[++PL_tmps_ix] = sv;
4640     SvTEMP_on(sv);
4641     return sv;
4642 }
4643
4644 /*
4645 =for apidoc newSVpv
4646
4647 Creates a new SV and copies a string into it.  The reference count for the
4648 SV is set to 1.  If C<len> is zero, Perl will compute the length using
4649 strlen().  For efficiency, consider using C<newSVpvn> instead.
4650
4651 =cut
4652 */
4653
4654 SV *
4655 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4656 {
4657     register SV *sv;
4658
4659     new_SV(sv);
4660     if (!len)
4661         len = strlen(s);
4662     sv_setpvn(sv,s,len);
4663     return sv;
4664 }
4665
4666 /*
4667 =for apidoc newSVpvn
4668
4669 Creates a new SV and copies a string into it.  The reference count for the
4670 SV is set to 1.  Note that if C<len> is zero, Perl will create a zero length
4671 string.  You are responsible for ensuring that the source string is at least
4672 C<len> bytes long.
4673
4674 =cut
4675 */
4676
4677 SV *
4678 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4679 {
4680     register SV *sv;
4681
4682     new_SV(sv);
4683     sv_setpvn(sv,s,len);
4684     return sv;
4685 }
4686
4687 #if defined(PERL_IMPLICIT_CONTEXT)
4688 SV *
4689 Perl_newSVpvf_nocontext(const char* pat, ...)
4690 {
4691     dTHX;
4692     register SV *sv;
4693     va_list args;
4694     va_start(args, pat);
4695     sv = vnewSVpvf(pat, &args);
4696     va_end(args);
4697     return sv;
4698 }
4699 #endif
4700
4701 /*
4702 =for apidoc newSVpvf
4703
4704 Creates a new SV an initialize it with the string formatted like
4705 C<sprintf>.
4706
4707 =cut
4708 */
4709
4710 SV *
4711 Perl_newSVpvf(pTHX_ const char* pat, ...)
4712 {
4713     register SV *sv;
4714     va_list args;
4715     va_start(args, pat);
4716     sv = vnewSVpvf(pat, &args);
4717     va_end(args);
4718     return sv;
4719 }
4720
4721 SV *
4722 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4723 {
4724     register SV *sv;
4725     new_SV(sv);
4726     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4727     return sv;
4728 }
4729
4730 /*
4731 =for apidoc newSVnv
4732
4733 Creates a new SV and copies a floating point value into it.
4734 The reference count for the SV is set to 1.
4735
4736 =cut
4737 */
4738
4739 SV *
4740 Perl_newSVnv(pTHX_ NV n)
4741 {
4742     register SV *sv;
4743
4744     new_SV(sv);
4745     sv_setnv(sv,n);
4746     return sv;
4747 }
4748
4749 /*
4750 =for apidoc newSViv
4751
4752 Creates a new SV and copies an integer into it.  The reference count for the
4753 SV is set to 1.
4754
4755 =cut
4756 */
4757
4758 SV *
4759 Perl_newSViv(pTHX_ IV i)
4760 {
4761     register SV *sv;
4762
4763     new_SV(sv);
4764     sv_setiv(sv,i);
4765     return sv;
4766 }
4767
4768 /*
4769 =for apidoc newSVuv
4770
4771 Creates a new SV and copies an unsigned integer into it.
4772 The reference count for the SV is set to 1.
4773
4774 =cut
4775 */
4776
4777 SV *
4778 Perl_newSVuv(pTHX_ UV u)
4779 {
4780     register SV *sv;
4781
4782     new_SV(sv);
4783     sv_setuv(sv,u);
4784     return sv;
4785 }
4786
4787 /*
4788 =for apidoc newRV_noinc
4789
4790 Creates an RV wrapper for an SV.  The reference count for the original
4791 SV is B<not> incremented.
4792
4793 =cut
4794 */
4795
4796 SV *
4797 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4798 {
4799     dTHR;
4800     register SV *sv;
4801
4802     new_SV(sv);
4803     sv_upgrade(sv, SVt_RV);
4804     SvTEMP_off(tmpRef);
4805     SvRV(sv) = tmpRef;
4806     SvROK_on(sv);
4807     return sv;
4808 }
4809
4810 /* newRV_inc is #defined to newRV in sv.h */
4811 SV *
4812 Perl_newRV(pTHX_ SV *tmpRef)
4813 {
4814     return newRV_noinc(SvREFCNT_inc(tmpRef));
4815 }
4816
4817 /*
4818 =for apidoc newSVsv
4819
4820 Creates a new SV which is an exact duplicate of the original SV.
4821
4822 =cut
4823 */
4824
4825 /* make an exact duplicate of old */
4826
4827 SV *
4828 Perl_newSVsv(pTHX_ register SV *old)
4829 {
4830     dTHR;
4831     register SV *sv;
4832
4833     if (!old)
4834         return Nullsv;
4835     if (SvTYPE(old) == SVTYPEMASK) {
4836         if (ckWARN_d(WARN_INTERNAL))
4837             Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4838         return Nullsv;
4839     }
4840     new_SV(sv);
4841     if (SvTEMP(old)) {
4842         SvTEMP_off(old);
4843         sv_setsv(sv,old);
4844         SvTEMP_on(old);
4845     }
4846     else
4847         sv_setsv(sv,old);
4848     return sv;
4849 }
4850
4851 void
4852 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4853 {
4854     register HE *entry;
4855     register GV *gv;
4856     register SV *sv;
4857     register I32 i;
4858     register PMOP *pm;
4859     register I32 max;
4860     char todo[PERL_UCHAR_MAX+1];
4861
4862     if (!stash)
4863         return;
4864
4865     if (!*s) {          /* reset ?? searches */
4866         for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4867             pm->op_pmdynflags &= ~PMdf_USED;
4868         }
4869         return;
4870     }
4871
4872     /* reset variables */
4873
4874     if (!HvARRAY(stash))
4875         return;
4876
4877     Zero(todo, 256, char);
4878     while (*s) {
4879         i = (unsigned char)*s;
4880         if (s[1] == '-') {
4881             s += 2;
4882         }
4883         max = (unsigned char)*s++;
4884         for ( ; i <= max; i++) {
4885             todo[i] = 1;
4886         }
4887         for (i = 0; i <= (I32) HvMAX(stash); i++) {
4888             for (entry = HvARRAY(stash)[i];
4889                  entry;
4890                  entry = HeNEXT(entry))
4891             {
4892                 if (!todo[(U8)*HeKEY(entry)])
4893                     continue;
4894                 gv = (GV*)HeVAL(entry);
4895                 sv = GvSV(gv);
4896                 if (SvTHINKFIRST(sv)) {
4897                     if (!SvREADONLY(sv) && SvROK(sv))
4898                         sv_unref(sv);
4899                     continue;
4900                 }
4901                 (void)SvOK_off(sv);
4902                 if (SvTYPE(sv) >= SVt_PV) {
4903                     SvCUR_set(sv, 0);
4904                     if (SvPVX(sv) != Nullch)
4905                         *SvPVX(sv) = '\0';
4906                     SvTAINT(sv);
4907                 }
4908                 if (GvAV(gv)) {
4909                     av_clear(GvAV(gv));
4910                 }
4911                 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4912                     hv_clear(GvHV(gv));
4913 #ifndef VMS  /* VMS has no environ array */
4914                     if (gv == PL_envgv)
4915                         environ[0] = Nullch;
4916 #endif
4917                 }
4918             }
4919         }
4920     }
4921 }
4922
4923 IO*
4924 Perl_sv_2io(pTHX_ SV *sv)
4925 {
4926     IO* io;
4927     GV* gv;
4928     STRLEN n_a;
4929
4930     switch (SvTYPE(sv)) {
4931     case SVt_PVIO:
4932         io = (IO*)sv;
4933         break;
4934     case SVt_PVGV:
4935         gv = (GV*)sv;
4936         io = GvIO(gv);
4937         if (!io)
4938             Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4939         break;
4940     default:
4941         if (!SvOK(sv))
4942             Perl_croak(aTHX_ PL_no_usym, "filehandle");
4943         if (SvROK(sv))
4944             return sv_2io(SvRV(sv));
4945         gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4946         if (gv)
4947             io = GvIO(gv);
4948         else
4949             io = 0;
4950         if (!io)
4951             Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4952         break;
4953     }
4954     return io;
4955 }
4956
4957 CV *
4958 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4959 {
4960     GV *gv;
4961     CV *cv;
4962     STRLEN n_a;
4963
4964     if (!sv)
4965         return *gvp = Nullgv, Nullcv;
4966     switch (SvTYPE(sv)) {
4967     case SVt_PVCV:
4968         *st = CvSTASH(sv);
4969         *gvp = Nullgv;
4970         return (CV*)sv;
4971     case SVt_PVHV:
4972     case SVt_PVAV:
4973         *gvp = Nullgv;
4974         return Nullcv;
4975     case SVt_PVGV:
4976         gv = (GV*)sv;
4977         *gvp = gv;
4978         *st = GvESTASH(gv);
4979         goto fix_gv;
4980
4981     default:
4982         if (SvGMAGICAL(sv))
4983             mg_get(sv);
4984         if (SvROK(sv)) {
4985             dTHR;
4986             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
4987             tryAMAGICunDEREF(to_cv);
4988
4989             sv = SvRV(sv);
4990             if (SvTYPE(sv) == SVt_PVCV) {
4991                 cv = (CV*)sv;
4992                 *gvp = Nullgv;
4993                 *st = CvSTASH(cv);
4994                 return cv;
4995             }
4996             else if(isGV(sv))
4997                 gv = (GV*)sv;
4998             else
4999                 Perl_croak(aTHX_ "Not a subroutine reference");
5000         }
5001         else if (isGV(sv))
5002             gv = (GV*)sv;
5003         else
5004             gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5005         *gvp = gv;
5006         if (!gv)
5007             return Nullcv;
5008         *st = GvESTASH(gv);
5009     fix_gv:
5010         if (lref && !GvCVu(gv)) {
5011             SV *tmpsv;
5012             ENTER;
5013             tmpsv = NEWSV(704,0);
5014             gv_efullname3(tmpsv, gv, Nullch);
5015             /* XXX this is probably not what they think they're getting.
5016              * It has the same effect as "sub name;", i.e. just a forward
5017              * declaration! */
5018             newSUB(start_subparse(FALSE, 0),
5019                    newSVOP(OP_CONST, 0, tmpsv),
5020                    Nullop,
5021                    Nullop);
5022             LEAVE;
5023             if (!GvCVu(gv))
5024                 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5025         }
5026         return GvCVu(gv);
5027     }
5028 }
5029
5030 I32
5031 Perl_sv_true(pTHX_ register SV *sv)
5032 {
5033     dTHR;
5034     if (!sv)
5035         return 0;
5036     if (SvPOK(sv)) {
5037         register XPV* tXpv;
5038         if ((tXpv = (XPV*)SvANY(sv)) &&
5039                 (tXpv->xpv_cur > 1 ||
5040                 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5041             return 1;
5042         else
5043             return 0;
5044     }
5045     else {
5046         if (SvIOK(sv))
5047             return SvIVX(sv) != 0;
5048         else {
5049             if (SvNOK(sv))
5050                 return SvNVX(sv) != 0.0;
5051             else
5052                 return sv_2bool(sv);
5053         }
5054     }
5055 }
5056
5057 IV
5058 Perl_sv_iv(pTHX_ register SV *sv)
5059 {
5060     if (SvIOK(sv)) {
5061         if (SvIsUV(sv))
5062             return (IV)SvUVX(sv);
5063         return SvIVX(sv);
5064     }
5065     return sv_2iv(sv);
5066 }
5067
5068 UV
5069 Perl_sv_uv(pTHX_ register SV *sv)
5070 {
5071     if (SvIOK(sv)) {
5072         if (SvIsUV(sv))
5073             return SvUVX(sv);
5074         return (UV)SvIVX(sv);
5075     }
5076     return sv_2uv(sv);
5077 }
5078
5079 NV
5080 Perl_sv_nv(pTHX_ register SV *sv)
5081 {
5082     if (SvNOK(sv))
5083         return SvNVX(sv);
5084     return sv_2nv(sv);
5085 }
5086
5087 char *
5088 Perl_sv_pv(pTHX_ SV *sv)
5089 {
5090     STRLEN n_a;
5091
5092     if (SvPOK(sv))
5093         return SvPVX(sv);
5094
5095     return sv_2pv(sv, &n_a);
5096 }
5097
5098 char *
5099 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5100 {
5101     if (SvPOK(sv)) {
5102         *lp = SvCUR(sv);
5103         return SvPVX(sv);
5104     }
5105     return sv_2pv(sv, lp);
5106 }
5107
5108 char *
5109 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5110 {
5111     char *s;
5112
5113     if (SvTHINKFIRST(sv) && !SvROK(sv))
5114         sv_force_normal(sv);
5115
5116     if (SvPOK(sv)) {
5117         *lp = SvCUR(sv);
5118     }
5119     else {
5120         if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5121             dTHR;
5122             Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5123                 PL_op_name[PL_op->op_type]);
5124         }
5125         else
5126             s = sv_2pv(sv, lp);
5127         if (s != SvPVX(sv)) {   /* Almost, but not quite, sv_setpvn() */
5128             STRLEN len = *lp;
5129
5130             if (SvROK(sv))
5131                 sv_unref(sv);
5132             (void)SvUPGRADE(sv, SVt_PV);                /* Never FALSE */
5133             SvGROW(sv, len + 1);
5134             Move(s,SvPVX(sv),len,char);
5135             SvCUR_set(sv, len);
5136             *SvEND(sv) = '\0';
5137         }
5138         if (!SvPOK(sv)) {
5139             SvPOK_on(sv);               /* validate pointer */
5140             SvTAINT(sv);
5141             DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5142                                   PTR2UV(sv),SvPVX(sv)));
5143         }
5144     }
5145     return SvPVX(sv);
5146 }
5147
5148 char *
5149 Perl_sv_pvbyte(pTHX_ SV *sv)
5150 {
5151     return sv_pv(sv);
5152 }
5153
5154 char *
5155 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5156 {
5157     return sv_pvn(sv,lp);
5158 }
5159
5160 char *
5161 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5162 {
5163     return sv_pvn_force(sv,lp);
5164 }
5165
5166 char *
5167 Perl_sv_pvutf8(pTHX_ SV *sv)
5168 {
5169     sv_utf8_upgrade(sv);
5170     return sv_pv(sv);
5171 }
5172
5173 char *
5174 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5175 {
5176     sv_utf8_upgrade(sv);
5177     return sv_pvn(sv,lp);
5178 }
5179
5180 char *
5181 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5182 {
5183     sv_utf8_upgrade(sv);
5184     return sv_pvn_force(sv,lp);
5185 }
5186
5187 char *
5188 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5189 {
5190     if (ob && SvOBJECT(sv))
5191         return HvNAME(SvSTASH(sv));
5192     else {
5193         switch (SvTYPE(sv)) {
5194         case SVt_NULL:
5195         case SVt_IV:
5196         case SVt_NV:
5197         case SVt_RV:
5198         case SVt_PV:
5199         case SVt_PVIV:
5200         case SVt_PVNV:
5201         case SVt_PVMG:
5202         case SVt_PVBM:
5203                                 if (SvROK(sv))
5204                                     return "REF";
5205                                 else
5206                                     return "SCALAR";
5207         case SVt_PVLV:          return "LVALUE";
5208         case SVt_PVAV:          return "ARRAY";
5209         case SVt_PVHV:          return "HASH";
5210         case SVt_PVCV:          return "CODE";
5211         case SVt_PVGV:          return "GLOB";
5212         case SVt_PVFM:          return "FORMAT";
5213         case SVt_PVIO:          return "IO";
5214         default:                return "UNKNOWN";
5215         }
5216     }
5217 }
5218
5219 /*
5220 =for apidoc sv_isobject
5221
5222 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5223 object.  If the SV is not an RV, or if the object is not blessed, then this
5224 will return false.
5225
5226 =cut
5227 */
5228
5229 int
5230 Perl_sv_isobject(pTHX_ SV *sv)
5231 {
5232     if (!sv)
5233         return 0;
5234     if (SvGMAGICAL(sv))
5235         mg_get(sv);
5236     if (!SvROK(sv))
5237         return 0;
5238     sv = (SV*)SvRV(sv);
5239     if (!SvOBJECT(sv))
5240         return 0;
5241     return 1;
5242 }
5243
5244 /*
5245 =for apidoc sv_isa
5246
5247 Returns a boolean indicating whether the SV is blessed into the specified
5248 class.  This does not check for subtypes; use C<sv_derived_from> to verify
5249 an inheritance relationship.
5250
5251 =cut
5252 */
5253
5254 int
5255 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5256 {
5257     if (!sv)
5258         return 0;
5259     if (SvGMAGICAL(sv))
5260         mg_get(sv);
5261     if (!SvROK(sv))
5262         return 0;
5263     sv = (SV*)SvRV(sv);
5264     if (!SvOBJECT(sv))
5265         return 0;
5266
5267     return strEQ(HvNAME(SvSTASH(sv)), name);
5268 }
5269
5270 /*
5271 =for apidoc newSVrv
5272
5273 Creates a new SV for the RV, C<rv>, to point to.  If C<rv> is not an RV then
5274 it will be upgraded to one.  If C<classname> is non-null then the new SV will
5275 be blessed in the specified package.  The new SV is returned and its
5276 reference count is 1.
5277
5278 =cut
5279 */
5280
5281 SV*
5282 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5283 {
5284     dTHR;
5285     SV *sv;
5286
5287     new_SV(sv);
5288
5289     SV_CHECK_THINKFIRST(rv);
5290     SvAMAGIC_off(rv);
5291
5292     if (SvTYPE(rv) < SVt_RV)
5293       sv_upgrade(rv, SVt_RV);
5294
5295     (void)SvOK_off(rv);
5296     SvRV(rv) = sv;
5297     SvROK_on(rv);
5298
5299     if (classname) {
5300         HV* stash = gv_stashpv(classname, TRUE);
5301         (void)sv_bless(rv, stash);
5302     }
5303     return sv;
5304 }
5305
5306 /*
5307 =for apidoc sv_setref_pv
5308
5309 Copies a pointer into a new SV, optionally blessing the SV.  The C<rv>
5310 argument will be upgraded to an RV.  That RV will be modified to point to
5311 the new SV.  If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5312 into the SV.  The C<classname> argument indicates the package for the
5313 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
5314 will be returned and will have a reference count of 1.
5315
5316 Do not use with other Perl types such as HV, AV, SV, CV, because those
5317 objects will become corrupted by the pointer copy process.
5318
5319 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5320
5321 =cut
5322 */
5323
5324 SV*
5325 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5326 {
5327     if (!pv) {
5328         sv_setsv(rv, &PL_sv_undef);
5329         SvSETMAGIC(rv);
5330     }
5331     else
5332         sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5333     return rv;
5334 }
5335
5336 /*
5337 =for apidoc sv_setref_iv
5338
5339 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
5340 argument will be upgraded to an RV.  That RV will be modified to point to
5341 the new SV.  The C<classname> argument indicates the package for the
5342 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
5343 will be returned and will have a reference count of 1.
5344
5345 =cut
5346 */
5347
5348 SV*
5349 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5350 {
5351     sv_setiv(newSVrv(rv,classname), iv);
5352     return rv;
5353 }
5354
5355 /*
5356 =for apidoc sv_setref_nv
5357
5358 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
5359 argument will be upgraded to an RV.  That RV will be modified to point to
5360 the new SV.  The C<classname> argument indicates the package for the
5361 blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
5362 will be returned and will have a reference count of 1.
5363
5364 =cut
5365 */
5366
5367 SV*
5368 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5369 {
5370     sv_setnv(newSVrv(rv,classname), nv);
5371     return rv;
5372 }
5373
5374 /*
5375 =for apidoc sv_setref_pvn
5376
5377 Copies a string into a new SV, optionally blessing the SV.  The length of the
5378 string must be specified with C<n>.  The C<rv> argument will be upgraded to
5379 an RV.  That RV will be modified to point to the new SV.  The C<classname>
5380 argument indicates the package for the blessing.  Set C<classname> to
5381 C<Nullch> to avoid the blessing.  The new SV will be returned and will have
5382 a reference count of 1.
5383
5384 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5385
5386 =cut
5387 */
5388
5389 SV*
5390 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5391 {
5392     sv_setpvn(newSVrv(rv,classname), pv, n);
5393     return rv;
5394 }
5395
5396 /*
5397 =for apidoc sv_bless
5398
5399 Blesses an SV into a specified package.  The SV must be an RV.  The package
5400 must be designated by its stash (see C<gv_stashpv()>).  The reference count
5401 of the SV is unaffected.
5402
5403 =cut
5404 */
5405
5406 SV*
5407 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5408 {
5409     dTHR;
5410     SV *tmpRef;
5411     if (!SvROK(sv))
5412         Perl_croak(aTHX_ "Can't bless non-reference value");
5413     tmpRef = SvRV(sv);
5414     if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5415         if (SvREADONLY(tmpRef))
5416             Perl_croak(aTHX_ PL_no_modify);
5417         if (SvOBJECT(tmpRef)) {
5418             if (SvTYPE(tmpRef) != SVt_PVIO)
5419                 --PL_sv_objcount;
5420             SvREFCNT_dec(SvSTASH(tmpRef));
5421         }
5422     }
5423     SvOBJECT_on(tmpRef);
5424     if (SvTYPE(tmpRef) != SVt_PVIO)
5425         ++PL_sv_objcount;
5426     (void)SvUPGRADE(tmpRef, SVt_PVMG);
5427     SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5428
5429     if (Gv_AMG(stash))
5430         SvAMAGIC_on(sv);
5431     else
5432         SvAMAGIC_off(sv);
5433
5434     return sv;
5435 }
5436
5437 STATIC void
5438 S_sv_unglob(pTHX_ SV *sv)
5439 {
5440     void *xpvmg;
5441
5442     assert(SvTYPE(sv) == SVt_PVGV);
5443     SvFAKE_off(sv);
5444     if (GvGP(sv))
5445         gp_free((GV*)sv);
5446     if (GvSTASH(sv)) {
5447         SvREFCNT_dec(GvSTASH(sv));
5448         GvSTASH(sv) = Nullhv;
5449     }
5450     sv_unmagic(sv, '*');
5451     Safefree(GvNAME(sv));
5452     GvMULTI_off(sv);
5453
5454     /* need to keep SvANY(sv) in the right arena */
5455     xpvmg = new_XPVMG();
5456     StructCopy(SvANY(sv), xpvmg, XPVMG);
5457     del_XPVGV(SvANY(sv));
5458     SvANY(sv) = xpvmg;
5459
5460     SvFLAGS(sv) &= ~SVTYPEMASK;
5461     SvFLAGS(sv) |= SVt_PVMG;
5462 }
5463
5464 /*
5465 =for apidoc sv_unref
5466
5467 Unsets the RV status of the SV, and decrements the reference count of
5468 whatever was being referenced by the RV.  This can almost be thought of
5469 as a reversal of C<newSVrv>.  See C<SvROK_off>.
5470
5471 =cut
5472 */
5473
5474 void
5475 Perl_sv_unref(pTHX_ SV *sv)
5476 {
5477     SV* rv = SvRV(sv);
5478
5479     if (SvWEAKREF(sv)) {
5480         sv_del_backref(sv);
5481         SvWEAKREF_off(sv);
5482         SvRV(sv) = 0;
5483         return;
5484     }
5485     SvRV(sv) = 0;
5486     SvROK_off(sv);
5487     if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5488         SvREFCNT_dec(rv);
5489     else
5490         sv_2mortal(rv);         /* Schedule for freeing later */
5491 }
5492
5493 void
5494 Perl_sv_taint(pTHX_ SV *sv)
5495 {
5496     sv_magic((sv), Nullsv, 't', Nullch, 0);
5497 }
5498
5499 void
5500 Perl_sv_untaint(pTHX_ SV *sv)
5501 {
5502     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5503         MAGIC *mg = mg_find(sv, 't');
5504         if (mg)
5505             mg->mg_len &= ~1;
5506     }
5507 }
5508
5509 bool
5510 Perl_sv_tainted(pTHX_ SV *sv)
5511 {
5512     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5513         MAGIC *mg = mg_find(sv, 't');
5514         if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5515             return TRUE;
5516     }
5517     return FALSE;
5518 }
5519
5520 /*
5521 =for apidoc sv_setpviv
5522
5523 Copies an integer into the given SV, also updating its string value.
5524 Does not handle 'set' magic.  See C<sv_setpviv_mg>.
5525
5526 =cut
5527 */
5528
5529 void
5530 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5531 {
5532     char buf[TYPE_CHARS(UV)];
5533     char *ebuf;
5534     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5535
5536     sv_setpvn(sv, ptr, ebuf - ptr);
5537 }
5538
5539
5540 /*
5541 =for apidoc sv_setpviv_mg
5542
5543 Like C<sv_setpviv>, but also handles 'set' magic.
5544
5545 =cut
5546 */
5547
5548 void
5549 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5550 {
5551     char buf[TYPE_CHARS(UV)];
5552     char *ebuf;
5553     char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5554
5555     sv_setpvn(sv, ptr, ebuf - ptr);
5556     SvSETMAGIC(sv);
5557 }
5558
5559 #if defined(PERL_IMPLICIT_CONTEXT)
5560 void
5561 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5562 {
5563     dTHX;
5564     va_list args;
5565     va_start(args, pat);
5566     sv_vsetpvf(sv, pat, &args);
5567     va_end(args);
5568 }
5569
5570
5571 void
5572 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5573 {
5574     dTHX;
5575     va_list args;
5576     va_start(args, pat);
5577     sv_vsetpvf_mg(sv, pat, &args);
5578     va_end(args);
5579 }
5580 #endif
5581
5582 /*
5583 =for apidoc sv_setpvf
5584
5585 Processes its arguments like C<sprintf> and sets an SV to the formatted
5586 output.  Does not handle 'set' magic.  See C<sv_setpvf_mg>.
5587
5588 =cut
5589 */
5590
5591 void
5592 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5593 {
5594     va_list args;
5595     va_start(args, pat);
5596     sv_vsetpvf(sv, pat, &args);
5597     va_end(args);
5598 }
5599
5600 void
5601 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5602 {
5603     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5604 }
5605
5606 /*
5607 =for apidoc sv_setpvf_mg
5608
5609 Like C<sv_setpvf>, but also handles 'set' magic.
5610
5611 =cut
5612 */
5613
5614 void
5615 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5616 {
5617     va_list args;
5618     va_start(args, pat);
5619     sv_vsetpvf_mg(sv, pat, &args);
5620     va_end(args);
5621 }
5622
5623 void
5624 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5625 {
5626     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5627     SvSETMAGIC(sv);
5628 }
5629
5630 #if defined(PERL_IMPLICIT_CONTEXT)
5631 void
5632 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5633 {
5634     dTHX;
5635     va_list args;
5636     va_start(args, pat);
5637     sv_vcatpvf(sv, pat, &args);
5638     va_end(args);
5639 }
5640
5641 void
5642 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5643 {
5644     dTHX;
5645     va_list args;
5646     va_start(args, pat);
5647     sv_vcatpvf_mg(sv, pat, &args);
5648     va_end(args);
5649 }
5650 #endif
5651
5652 /*
5653 =for apidoc sv_catpvf
5654
5655 Processes its arguments like C<sprintf> and appends the formatted output
5656 to an SV.  Handles 'get' magic, but not 'set' magic.  C<SvSETMAGIC()> must
5657 typically be called after calling this function to handle 'set' magic.
5658
5659 =cut
5660 */
5661
5662 void
5663 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5664 {
5665     va_list args;
5666     va_start(args, pat);
5667     sv_vcatpvf(sv, pat, &args);
5668     va_end(args);
5669 }
5670
5671 void
5672 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5673 {
5674     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5675 }
5676
5677 /*
5678 =for apidoc sv_catpvf_mg
5679
5680 Like C<sv_catpvf>, but also handles 'set' magic.
5681
5682 =cut
5683 */
5684
5685 void
5686 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5687 {
5688     va_list args;
5689     va_start(args, pat);
5690     sv_vcatpvf_mg(sv, pat, &args);
5691     va_end(args);
5692 }
5693
5694 void
5695 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5696 {
5697     sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5698     SvSETMAGIC(sv);
5699 }
5700
5701 /*
5702 =for apidoc sv_vsetpvfn
5703
5704 Works like C<vcatpvfn> but copies the text into the SV instead of
5705 appending it.
5706
5707 =cut
5708 */
5709
5710 void
5711 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5712 {
5713     sv_setpvn(sv, "", 0);
5714     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5715 }
5716
5717 /*
5718 =for apidoc sv_vcatpvfn
5719
5720 Processes its arguments like C<vsprintf> and appends the formatted output
5721 to an SV.  Uses an array of SVs if the C style variable argument list is
5722 missing (NULL).  When running with taint checks enabled, indicates via
5723 C<maybe_tainted> if results are untrustworthy (often due to the use of
5724 locales).
5725
5726 =cut
5727 */
5728
5729 void
5730 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5731 {
5732     dTHR;
5733     char *p;
5734     char *q;
5735     char *patend;
5736     STRLEN origlen;
5737     I32 svix = 0;
5738     static char nullstr[] = "(null)";
5739     SV *argsv;
5740
5741     /* no matter what, this is a string now */
5742     (void)SvPV_force(sv, origlen);
5743
5744     /* special-case "", "%s", and "%_" */
5745     if (patlen == 0)
5746         return;
5747     if (patlen == 2 && pat[0] == '%') {
5748         switch (pat[1]) {
5749         case 's':
5750             if (args) {
5751                 char *s = va_arg(*args, char*);
5752                 sv_catpv(sv, s ? s : nullstr);
5753             }
5754             else if (svix < svmax) {
5755                 sv_catsv(sv, *svargs);
5756                 if (DO_UTF8(*svargs))
5757                     SvUTF8_on(sv);
5758             }
5759             return;
5760         case '_':
5761             if (args) {
5762                 argsv = va_arg(*args, SV*);
5763                 sv_catsv(sv, argsv);
5764                 if (DO_UTF8(argsv))
5765                     SvUTF8_on(sv);
5766                 return;
5767             }
5768             /* See comment on '_' below */
5769             break;
5770         }
5771     }
5772
5773     patend = (char*)pat + patlen;
5774     for (p = (char*)pat; p < patend; p = q) {
5775         bool alt = FALSE;
5776         bool left = FALSE;
5777         bool vectorize = FALSE;
5778         bool utf = FALSE;
5779         char fill = ' ';
5780         char plus = 0;
5781         char intsize = 0;
5782         STRLEN width = 0;
5783         STRLEN zeros = 0;
5784         bool has_precis = FALSE;
5785         STRLEN precis = 0;
5786         bool is_utf = FALSE;
5787
5788         char esignbuf[4];
5789         U8 utf8buf[UTF8_MAXLEN];
5790         STRLEN esignlen = 0;
5791
5792         char *eptr = Nullch;
5793         STRLEN elen = 0;
5794         /* Times 4: a decimal digit takes more than 3 binary digits.
5795          * NV_DIG: mantissa takes than many decimal digits.
5796          * Plus 32: Playing safe. */
5797         char ebuf[IV_DIG * 4 + NV_DIG + 32];
5798         /* large enough for "%#.#f" --chip */
5799         /* what about long double NVs? --jhi */
5800
5801         SV *vecsv;
5802         U8 *vecstr = Null(U8*);
5803         STRLEN veclen = 0;
5804         char c;
5805         int i;
5806         unsigned base;
5807         IV iv;
5808         UV uv;
5809         NV nv;
5810         STRLEN have;
5811         STRLEN need;
5812         STRLEN gap;
5813         char *dotstr = ".";
5814         STRLEN dotstrlen = 1;
5815
5816         for (q = p; q < patend && *q != '%'; ++q) ;
5817         if (q > p) {
5818             sv_catpvn(sv, p, q - p);
5819             p = q;
5820         }
5821         if (q++ >= patend)
5822             break;
5823
5824         /* FLAGS */
5825
5826         while (*q) {
5827             switch (*q) {
5828             case ' ':
5829             case '+':
5830                 plus = *q++;
5831                 continue;
5832
5833             case '-':
5834                 left = TRUE;
5835                 q++;
5836                 continue;
5837
5838             case '0':
5839                 fill = *q++;
5840                 continue;
5841
5842             case '#':
5843                 alt = TRUE;
5844                 q++;
5845                 continue;
5846
5847             case '*':                   /* printf("%*vX",":",$ipv6addr) */
5848                 if (q[1] != 'v')
5849                     break;
5850                 q++;
5851                 if (args)
5852                     vecsv = va_arg(*args, SV*);
5853                 else if (svix < svmax)
5854                     vecsv = svargs[svix++];
5855                 else
5856                     continue;
5857                 dotstr = SvPVx(vecsv,dotstrlen);
5858                 if (DO_UTF8(vecsv))
5859                     is_utf = TRUE;
5860                 /* FALL THROUGH */
5861
5862             case 'v':
5863                 vectorize = TRUE;
5864                 q++;
5865                 if (args)
5866                     vecsv = va_arg(*args, SV*);
5867                 else if (svix < svmax)
5868                     vecsv = svargs[svix++];
5869                 else {
5870                     vecstr = (U8*)"";
5871                     veclen = 0;
5872                     continue;
5873                 }
5874                 vecstr = (U8*)SvPVx(vecsv,veclen);
5875                 utf = DO_UTF8(vecsv);
5876                 continue;
5877
5878             default:
5879                 break;
5880             }
5881             break;
5882         }
5883
5884         /* WIDTH */
5885
5886         switch (*q) {
5887         case '1': case '2': case '3':
5888         case '4': case '5': case '6':
5889         case '7': case '8': case '9':
5890             width = 0;
5891             while (isDIGIT(*q))
5892                 width = width * 10 + (*q++ - '0');
5893             break;
5894
5895         case '*':
5896             if (args)
5897                 i = va_arg(*args, int);
5898             else
5899                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5900             left |= (i < 0);
5901             width = (i < 0) ? -i : i;
5902             q++;
5903             break;
5904         }
5905
5906         /* PRECISION */
5907
5908         if (*q == '.') {
5909             q++;
5910             if (*q == '*') {
5911                 if (args)
5912                     i = va_arg(*args, int);
5913                 else
5914                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5915                 precis = (i < 0) ? 0 : i;
5916                 q++;
5917             }
5918             else {
5919                 precis = 0;
5920                 while (isDIGIT(*q))
5921                     precis = precis * 10 + (*q++ - '0');
5922             }
5923             has_precis = TRUE;
5924         }
5925
5926         /* SIZE */
5927
5928         switch (*q) {
5929 #ifdef HAS_QUAD
5930         case 'L':                       /* Ld */
5931         case 'q':                       /* qd */
5932             intsize = 'q';
5933             q++;
5934             break;
5935 #endif
5936         case 'l':
5937 #ifdef HAS_QUAD
5938              if (*(q + 1) == 'l') {     /* lld */
5939                 intsize = 'q';
5940                 q += 2;
5941                 break;
5942              }
5943 #endif
5944             /* FALL THROUGH */
5945         case 'h':
5946             /* FALL THROUGH */
5947         case 'V':
5948             intsize = *q++;
5949             break;
5950         }
5951
5952         /* CONVERSION */
5953
5954         switch (c = *q++) {
5955
5956             /* STRINGS */
5957
5958         case '%':
5959             eptr = q - 1;
5960             elen = 1;
5961             goto string;
5962
5963         case 'c':
5964             if (args)
5965                 uv = va_arg(*args, int);
5966             else
5967                 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5968             if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
5969                 eptr = (char*)utf8buf;
5970                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5971                 is_utf = TRUE;
5972             }
5973             else {
5974                 c = (char)uv;
5975                 eptr = &c;
5976                 elen = 1;
5977             }
5978             goto string;
5979
5980         case 's':
5981             if (args) {
5982                 eptr = va_arg(*args, char*);
5983                 if (eptr)
5984 #ifdef MACOS_TRADITIONAL
5985                   /* On MacOS, %#s format is used for Pascal strings */
5986                   if (alt)
5987                     elen = *eptr++;
5988                   else
5989 #endif
5990                     elen = strlen(eptr);
5991                 else {
5992                     eptr = nullstr;
5993                     elen = sizeof nullstr - 1;
5994                 }
5995             }
5996             else if (svix < svmax) {
5997                 argsv = svargs[svix++];
5998                 eptr = SvPVx(argsv, elen);
5999                 if (DO_UTF8(argsv)) {
6000                     if (has_precis && precis < elen) {
6001                         I32 p = precis;
6002                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6003                         precis = p;
6004                     }
6005                     if (width) { /* fudge width (can't fudge elen) */
6006                         width += elen - sv_len_utf8(argsv);
6007                     }
6008                     is_utf = TRUE;
6009                 }
6010             }
6011             goto string;
6012
6013         case '_':
6014             /*
6015              * The "%_" hack might have to be changed someday,
6016              * if ISO or ANSI decide to use '_' for something.
6017              * So we keep it hidden from users' code.
6018              */
6019             if (!args)
6020                 goto unknown;
6021             argsv = va_arg(*args,SV*);
6022             eptr = SvPVx(argsv, elen);
6023             if (DO_UTF8(argsv))
6024                 is_utf = TRUE;
6025
6026         string:
6027             vectorize = FALSE;
6028             if (has_precis && elen > precis)
6029                 elen = precis;
6030             break;
6031
6032             /* INTEGERS */
6033
6034         case 'p':
6035             if (args)
6036                 uv = PTR2UV(va_arg(*args, void*));
6037             else
6038                 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6039             base = 16;
6040             goto integer;
6041
6042         case 'D':
6043 #ifdef IV_IS_QUAD
6044             intsize = 'q';
6045 #else
6046             intsize = 'l';
6047 #endif
6048             /* FALL THROUGH */
6049         case 'd':
6050         case 'i':
6051             if (vectorize) {
6052                 I32 ulen;
6053                 if (!veclen) {
6054                     vectorize = FALSE;
6055                     break;
6056                 }
6057                 if (utf)
6058                     iv = (IV)utf8_to_uv(vecstr, &ulen);
6059                 else {
6060                     iv = *vecstr;
6061                     ulen = 1;
6062                 }
6063                 vecstr += ulen;
6064                 veclen -= ulen;
6065             }
6066             else if (args) {
6067                 switch (intsize) {
6068                 case 'h':       iv = (short)va_arg(*args, int); break;
6069                 default:        iv = va_arg(*args, int); break;
6070                 case 'l':       iv = va_arg(*args, long); break;
6071                 case 'V':       iv = va_arg(*args, IV); break;
6072 #ifdef HAS_QUAD
6073                 case 'q':       iv = va_arg(*args, Quad_t); break;
6074 #endif
6075                 }
6076             }
6077             else {
6078                 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6079                 switch (intsize) {
6080                 case 'h':       iv = (short)iv; break;
6081                 default:        break;
6082                 case 'l':       iv = (long)iv; break;
6083                 case 'V':       break;
6084 #ifdef HAS_QUAD
6085                 case 'q':       iv = (Quad_t)iv; break;
6086 #endif
6087                 }
6088             }
6089             if (iv >= 0) {
6090                 uv = iv;
6091                 if (plus)
6092                     esignbuf[esignlen++] = plus;
6093             }
6094             else {
6095                 uv = -iv;
6096                 esignbuf[esignlen++] = '-';
6097             }
6098             base = 10;
6099             goto integer;
6100
6101         case 'U':
6102 #ifdef IV_IS_QUAD
6103             intsize = 'q';
6104 #else
6105             intsize = 'l';
6106 #endif
6107             /* FALL THROUGH */
6108         case 'u':
6109             base = 10;
6110             goto uns_integer;
6111
6112         case 'b':
6113             base = 2;
6114             goto uns_integer;
6115
6116         case 'O':
6117 #ifdef IV_IS_QUAD
6118             intsize = 'q';
6119 #else
6120             intsize = 'l';
6121 #endif
6122             /* FALL THROUGH */
6123         case 'o':
6124             base = 8;
6125             goto uns_integer;
6126
6127         case 'X':
6128         case 'x':
6129             base = 16;
6130
6131         uns_integer:
6132             if (vectorize) {
6133                 I32 ulen;
6134         vector:
6135                 if (!veclen) {
6136                     vectorize = FALSE;
6137                     break;
6138                 }
6139                 if (utf)
6140                     uv = utf8_to_uv(vecstr, &ulen);
6141                 else {
6142                     uv = *vecstr;
6143                     ulen = 1;
6144                 }
6145                 vecstr += ulen;
6146                 veclen -= ulen;
6147             }
6148             else if (args) {
6149                 switch (intsize) {
6150                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
6151                 default:   uv = va_arg(*args, unsigned); break;
6152                 case 'l':  uv = va_arg(*args, unsigned long); break;
6153                 case 'V':  uv = va_arg(*args, UV); break;
6154 #ifdef HAS_QUAD
6155                 case 'q':  uv = va_arg(*args, Quad_t); break;
6156 #endif
6157                 }
6158             }
6159             else {
6160                 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6161                 switch (intsize) {
6162                 case 'h':       uv = (unsigned short)uv; break;
6163                 default:        break;
6164                 case 'l':       uv = (unsigned long)uv; break;
6165                 case 'V':       break;
6166 #ifdef HAS_QUAD
6167                 case 'q':       uv = (Quad_t)uv; break;
6168 #endif
6169                 }
6170             }
6171
6172         integer:
6173             eptr = ebuf + sizeof ebuf;
6174             switch (base) {
6175                 unsigned dig;
6176             case 16:
6177                 if (!uv)
6178                     alt = FALSE;
6179                 p = (char*)((c == 'X')
6180                             ? "0123456789ABCDEF" : "0123456789abcdef");
6181                 do {
6182                     dig = uv & 15;
6183                     *--eptr = p[dig];
6184                 } while (uv >>= 4);
6185                 if (alt) {
6186                     esignbuf[esignlen++] = '0';
6187                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
6188                 }
6189                 break;
6190             case 8:
6191                 do {
6192                     dig = uv & 7;
6193                     *--eptr = '0' + dig;
6194                 } while (uv >>= 3);
6195                 if (alt && *eptr != '0')
6196                     *--eptr = '0';
6197                 break;
6198             case 2:
6199                 do {
6200                     dig = uv & 1;
6201                     *--eptr = '0' + dig;
6202                 } while (uv >>= 1);
6203                 if (alt) {
6204                     esignbuf[esignlen++] = '0';
6205                     esignbuf[esignlen++] = 'b';
6206                 }
6207                 break;
6208             default:            /* it had better be ten or less */
6209 #if defined(PERL_Y2KWARN)
6210                 if (ckWARN(WARN_Y2K)) {
6211                     STRLEN n;
6212                     char *s = SvPV(sv,n);
6213                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6214                         && (n == 2 || !isDIGIT(s[n-3])))
6215                     {
6216                         Perl_warner(aTHX_ WARN_Y2K,
6217                                     "Possible Y2K bug: %%%c %s",
6218                                     c, "format string following '19'");
6219                     }
6220                 }
6221 #endif
6222                 do {
6223                     dig = uv % base;
6224                     *--eptr = '0' + dig;
6225                 } while (uv /= base);
6226                 break;
6227             }
6228             elen = (ebuf + sizeof ebuf) - eptr;
6229             if (has_precis) {
6230                 if (precis > elen)
6231                     zeros = precis - elen;
6232                 else if (precis == 0 && elen == 1 && *eptr == '0')
6233                     elen = 0;
6234             }
6235             break;
6236
6237             /* FLOATING POINT */
6238
6239         case 'F':
6240             c = 'f';            /* maybe %F isn't supported here */
6241             /* FALL THROUGH */
6242         case 'e': case 'E':
6243         case 'f':
6244         case 'g': case 'G':
6245
6246             /* This is evil, but floating point is even more evil */
6247
6248             vectorize = FALSE;
6249             if (args)
6250                 nv = va_arg(*args, NV);
6251             else
6252                 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6253
6254             need = 0;
6255             if (c != 'e' && c != 'E') {
6256                 i = PERL_INT_MIN;
6257                 (void)Perl_frexp(nv, &i);
6258                 if (i == PERL_INT_MIN)
6259                     Perl_die(aTHX_ "panic: frexp");
6260                 if (i > 0)
6261                     need = BIT_DIGITS(i);
6262             }
6263             need += has_precis ? precis : 6; /* known default */
6264             if (need < width)
6265                 need = width;
6266
6267             need += 20; /* fudge factor */
6268             if (PL_efloatsize < need) {
6269                 Safefree(PL_efloatbuf);
6270                 PL_efloatsize = need + 20; /* more fudge */
6271                 New(906, PL_efloatbuf, PL_efloatsize, char);
6272                 PL_efloatbuf[0] = '\0';
6273             }
6274
6275             eptr = ebuf + sizeof ebuf;
6276             *--eptr = '\0';
6277             *--eptr = c;
6278 #ifdef USE_LONG_DOUBLE
6279             {
6280                 static char const my_prifldbl[] = PERL_PRIfldbl;
6281                 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6282                 while (p >= my_prifldbl) { *--eptr = *p--; }
6283             }
6284 #endif
6285             if (has_precis) {
6286                 base = precis;
6287                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6288                 *--eptr = '.';
6289             }
6290             if (width) {
6291                 base = width;
6292                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6293             }
6294             if (fill == '0')
6295                 *--eptr = fill;
6296             if (left)
6297                 *--eptr = '-';
6298             if (plus)
6299                 *--eptr = plus;
6300             if (alt)
6301                 *--eptr = '#';
6302             *--eptr = '%';
6303
6304             {
6305                 RESTORE_NUMERIC_STANDARD();
6306                 (void)sprintf(PL_efloatbuf, eptr, nv);
6307                 RESTORE_NUMERIC_LOCAL();
6308             }
6309
6310             eptr = PL_efloatbuf;
6311             elen = strlen(PL_efloatbuf);
6312             break;
6313
6314             /* SPECIAL */
6315
6316         case 'n':
6317             vectorize = FALSE;
6318             i = SvCUR(sv) - origlen;
6319             if (args) {
6320                 switch (intsize) {
6321                 case 'h':       *(va_arg(*args, short*)) = i; break;
6322                 default:        *(va_arg(*args, int*)) = i; break;
6323                 case 'l':       *(va_arg(*args, long*)) = i; break;
6324                 case 'V':       *(va_arg(*args, IV*)) = i; break;
6325 #ifdef HAS_QUAD
6326                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
6327 #endif
6328                 }
6329             }
6330             else if (svix < svmax)
6331                 sv_setuv(svargs[svix++], (UV)i);
6332             continue;   /* not "break" */
6333
6334             /* UNKNOWN */
6335
6336         default:
6337       unknown:
6338             vectorize = FALSE;
6339             if (!args && ckWARN(WARN_PRINTF) &&
6340                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6341                 SV *msg = sv_newmortal();
6342                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6343                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6344                 if (c) {
6345                     if (isPRINT(c))
6346                         Perl_sv_catpvf(aTHX_ msg,
6347                                        "\"%%%c\"", c & 0xFF);
6348                     else
6349                         Perl_sv_catpvf(aTHX_ msg,
6350                                        "\"%%\\%03"UVof"\"",
6351                                        (UV)c & 0xFF);
6352                 } else
6353                     sv_catpv(msg, "end of string");
6354                 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6355             }
6356
6357             /* output mangled stuff ... */
6358             if (c == '\0')
6359                 --q;
6360             eptr = p;
6361             elen = q - p;
6362
6363             /* ... right here, because formatting flags should not apply */
6364             SvGROW(sv, SvCUR(sv) + elen + 1);
6365             p = SvEND(sv);
6366             memcpy(p, eptr, elen);
6367             p += elen;
6368             *p = '\0';
6369             SvCUR(sv) = p - SvPVX(sv);
6370             continue;   /* not "break" */
6371         }
6372
6373         have = esignlen + zeros + elen;
6374         need = (have > width ? have : width);
6375         gap = need - have;
6376
6377         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6378         p = SvEND(sv);
6379         if (esignlen && fill == '0') {
6380             for (i = 0; i < esignlen; i++)
6381                 *p++ = esignbuf[i];
6382         }
6383         if (gap && !left) {
6384             memset(p, fill, gap);
6385             p += gap;
6386         }
6387         if (esignlen && fill != '0') {
6388             for (i = 0; i < esignlen; i++)
6389                 *p++ = esignbuf[i];
6390         }
6391         if (zeros) {
6392             for (i = zeros; i; i--)
6393                 *p++ = '0';
6394         }
6395         if (elen) {
6396             memcpy(p, eptr, elen);
6397             p += elen;
6398         }
6399         if (gap && left) {
6400             memset(p, ' ', gap);
6401             p += gap;
6402         }
6403         if (vectorize) {
6404             if (veclen) {
6405                 memcpy(p, dotstr, dotstrlen);
6406                 p += dotstrlen;
6407             }
6408             else
6409                 vectorize = FALSE;              /* done iterating over vecstr */
6410         }
6411         if (is_utf)
6412             SvUTF8_on(sv);
6413         *p = '\0';
6414         SvCUR(sv) = p - SvPVX(sv);
6415         if (vectorize) {
6416             esignlen = 0;
6417             goto vector;
6418         }
6419     }
6420 }
6421
6422 #if defined(USE_ITHREADS)
6423
6424 #if defined(USE_THREADS)
6425 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
6426 #endif
6427
6428 #ifndef GpREFCNT_inc
6429 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6430 #endif
6431
6432
6433 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
6434 #define av_dup(s)       (AV*)sv_dup((SV*)s)
6435 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6436 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
6437 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6438 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
6439 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6440 #define io_dup(s)       (IO*)sv_dup((SV*)s)
6441 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6442 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
6443 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6444 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
6445 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
6446
6447 REGEXP *
6448 Perl_re_dup(pTHX_ REGEXP *r)
6449 {
6450     /* XXX fix when pmop->op_pmregexp becomes shared */
6451     return ReREFCNT_inc(r);
6452 }
6453
6454 PerlIO *
6455 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6456 {
6457     PerlIO *ret;
6458     if (!fp)
6459         return (PerlIO*)NULL;
6460
6461     /* look for it in the table first */
6462     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6463     if (ret)
6464         return ret;
6465
6466     /* create anew and remember what it is */
6467     ret = PerlIO_fdupopen(fp);
6468     ptr_table_store(PL_ptr_table, fp, ret);
6469     return ret;
6470 }
6471
6472 DIR *
6473 Perl_dirp_dup(pTHX_ DIR *dp)
6474 {
6475     if (!dp)
6476         return (DIR*)NULL;
6477     /* XXX TODO */
6478     return dp;
6479 }
6480
6481 GP *
6482 Perl_gp_dup(pTHX_ GP *gp)
6483 {
6484     GP *ret;
6485     if (!gp)
6486         return (GP*)NULL;
6487     /* look for it in the table first */
6488     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6489     if (ret)
6490         return ret;
6491
6492     /* create anew and remember what it is */
6493     Newz(0, ret, 1, GP);
6494     ptr_table_store(PL_ptr_table, gp, ret);
6495
6496     /* clone */
6497     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
6498     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
6499     ret->gp_io          = io_dup_inc(gp->gp_io);
6500     ret->gp_form        = cv_dup_inc(gp->gp_form);
6501     ret->gp_av          = av_dup_inc(gp->gp_av);
6502     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
6503     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
6504     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
6505     ret->gp_cvgen       = gp->gp_cvgen;
6506     ret->gp_flags       = gp->gp_flags;
6507     ret->gp_line        = gp->gp_line;
6508     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
6509     return ret;
6510 }
6511
6512 MAGIC *
6513 Perl_mg_dup(pTHX_ MAGIC *mg)
6514 {
6515     MAGIC *mgret = (MAGIC*)NULL;
6516     MAGIC *mgprev;
6517     if (!mg)
6518         return (MAGIC*)NULL;
6519     /* look for it in the table first */
6520     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6521     if (mgret)
6522         return mgret;
6523
6524     for (; mg; mg = mg->mg_moremagic) {
6525         MAGIC *nmg;
6526         Newz(0, nmg, 1, MAGIC);
6527         if (!mgret)
6528             mgret = nmg;
6529         else
6530             mgprev->mg_moremagic = nmg;
6531         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
6532         nmg->mg_private = mg->mg_private;
6533         nmg->mg_type    = mg->mg_type;
6534         nmg->mg_flags   = mg->mg_flags;
6535         if (mg->mg_type == 'r') {
6536             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6537         }
6538         else {
6539             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6540                               ? sv_dup_inc(mg->mg_obj)
6541                               : sv_dup(mg->mg_obj);
6542         }
6543         nmg->mg_len     = mg->mg_len;
6544         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
6545         if (mg->mg_ptr && mg->mg_type != 'g') {
6546             if (mg->mg_len >= 0) {
6547                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
6548                 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6549                     AMT *amtp = (AMT*)mg->mg_ptr;
6550                     AMT *namtp = (AMT*)nmg->mg_ptr;
6551                     I32 i;
6552                     for (i = 1; i < NofAMmeth; i++) {
6553                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
6554                     }
6555                 }
6556             }
6557             else if (mg->mg_len == HEf_SVKEY)
6558                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6559         }
6560         mgprev = nmg;
6561     }
6562     return mgret;
6563 }
6564
6565 PTR_TBL_t *
6566 Perl_ptr_table_new(pTHX)
6567 {
6568     PTR_TBL_t *tbl;
6569     Newz(0, tbl, 1, PTR_TBL_t);
6570     tbl->tbl_max        = 511;
6571     tbl->tbl_items      = 0;
6572     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6573     return tbl;
6574 }
6575
6576 void *
6577 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6578 {
6579     PTR_TBL_ENT_t *tblent;
6580     UV hash = PTR2UV(sv);
6581     assert(tbl);
6582     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6583     for (; tblent; tblent = tblent->next) {
6584         if (tblent->oldval == sv)
6585             return tblent->newval;
6586     }
6587     return (void*)NULL;
6588 }
6589
6590 void
6591 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6592 {
6593     PTR_TBL_ENT_t *tblent, **otblent;
6594     /* XXX this may be pessimal on platforms where pointers aren't good
6595      * hash values e.g. if they grow faster in the most significant
6596      * bits */
6597     UV hash = PTR2UV(oldv);
6598     bool i = 1;
6599
6600     assert(tbl);
6601     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6602     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6603         if (tblent->oldval == oldv) {
6604             tblent->newval = newv;
6605             tbl->tbl_items++;
6606             return;
6607         }
6608     }
6609     Newz(0, tblent, 1, PTR_TBL_ENT_t);
6610     tblent->oldval = oldv;
6611     tblent->newval = newv;
6612     tblent->next = *otblent;
6613     *otblent = tblent;
6614     tbl->tbl_items++;
6615     if (i && tbl->tbl_items > tbl->tbl_max)
6616         ptr_table_split(tbl);
6617 }
6618
6619 void
6620 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6621 {
6622     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6623     UV oldsize = tbl->tbl_max + 1;
6624     UV newsize = oldsize * 2;
6625     UV i;
6626
6627     Renew(ary, newsize, PTR_TBL_ENT_t*);
6628     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6629     tbl->tbl_max = --newsize;
6630     tbl->tbl_ary = ary;
6631     for (i=0; i < oldsize; i++, ary++) {
6632         PTR_TBL_ENT_t **curentp, **entp, *ent;
6633         if (!*ary)
6634             continue;
6635         curentp = ary + oldsize;
6636         for (entp = ary, ent = *ary; ent; ent = *entp) {
6637             if ((newsize & PTR2UV(ent->oldval)) != i) {
6638                 *entp = ent->next;
6639                 ent->next = *curentp;
6640                 *curentp = ent;
6641                 continue;
6642             }
6643             else
6644                 entp = &ent->next;
6645         }
6646     }
6647 }
6648
6649 #ifdef DEBUGGING
6650 char *PL_watch_pvx;
6651 #endif
6652
6653 SV *
6654 Perl_sv_dup(pTHX_ SV *sstr)
6655 {
6656     SV *dstr;
6657
6658     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6659         return Nullsv;
6660     /* look for it in the table first */
6661     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6662     if (dstr)
6663         return dstr;
6664
6665     /* create anew and remember what it is */
6666     new_SV(dstr);
6667     ptr_table_store(PL_ptr_table, sstr, dstr);
6668
6669     /* clone */
6670     SvFLAGS(dstr)       = SvFLAGS(sstr);
6671     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
6672     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
6673
6674 #ifdef DEBUGGING
6675     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6676         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6677                       PL_watch_pvx, SvPVX(sstr));
6678 #endif
6679
6680     switch (SvTYPE(sstr)) {
6681     case SVt_NULL:
6682         SvANY(dstr)     = NULL;
6683         break;
6684     case SVt_IV:
6685         SvANY(dstr)     = new_XIV();
6686         SvIVX(dstr)     = SvIVX(sstr);
6687         break;
6688     case SVt_NV:
6689         SvANY(dstr)     = new_XNV();
6690         SvNVX(dstr)     = SvNVX(sstr);
6691         break;
6692     case SVt_RV:
6693         SvANY(dstr)     = new_XRV();
6694         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
6695         break;
6696     case SVt_PV:
6697         SvANY(dstr)     = new_XPV();
6698         SvCUR(dstr)     = SvCUR(sstr);
6699         SvLEN(dstr)     = SvLEN(sstr);
6700         if (SvROK(sstr))
6701             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6702         else if (SvPVX(sstr) && SvLEN(sstr))
6703             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6704         else
6705             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6706         break;
6707     case SVt_PVIV:
6708         SvANY(dstr)     = new_XPVIV();
6709         SvCUR(dstr)     = SvCUR(sstr);
6710         SvLEN(dstr)     = SvLEN(sstr);
6711         SvIVX(dstr)     = SvIVX(sstr);
6712         if (SvROK(sstr))
6713             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6714         else if (SvPVX(sstr) && SvLEN(sstr))
6715             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6716         else
6717             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6718         break;
6719     case SVt_PVNV:
6720         SvANY(dstr)     = new_XPVNV();
6721         SvCUR(dstr)     = SvCUR(sstr);
6722         SvLEN(dstr)     = SvLEN(sstr);
6723         SvIVX(dstr)     = SvIVX(sstr);
6724         SvNVX(dstr)     = SvNVX(sstr);
6725         if (SvROK(sstr))
6726             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6727         else if (SvPVX(sstr) && SvLEN(sstr))
6728             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6729         else
6730             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6731         break;
6732     case SVt_PVMG:
6733         SvANY(dstr)     = new_XPVMG();
6734         SvCUR(dstr)     = SvCUR(sstr);
6735         SvLEN(dstr)     = SvLEN(sstr);
6736         SvIVX(dstr)     = SvIVX(sstr);
6737         SvNVX(dstr)     = SvNVX(sstr);
6738         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6739         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6740         if (SvROK(sstr))
6741             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6742         else if (SvPVX(sstr) && SvLEN(sstr))
6743             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6744         else
6745             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6746         break;
6747     case SVt_PVBM:
6748         SvANY(dstr)     = new_XPVBM();
6749         SvCUR(dstr)     = SvCUR(sstr);
6750         SvLEN(dstr)     = SvLEN(sstr);
6751         SvIVX(dstr)     = SvIVX(sstr);
6752         SvNVX(dstr)     = SvNVX(sstr);
6753         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6754         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6755         if (SvROK(sstr))
6756             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6757         else if (SvPVX(sstr) && SvLEN(sstr))
6758             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6759         else
6760             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6761         BmRARE(dstr)    = BmRARE(sstr);
6762         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
6763         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6764         break;
6765     case SVt_PVLV:
6766         SvANY(dstr)     = new_XPVLV();
6767         SvCUR(dstr)     = SvCUR(sstr);
6768         SvLEN(dstr)     = SvLEN(sstr);
6769         SvIVX(dstr)     = SvIVX(sstr);
6770         SvNVX(dstr)     = SvNVX(sstr);
6771         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6772         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6773         if (SvROK(sstr))
6774             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6775         else if (SvPVX(sstr) && SvLEN(sstr))
6776             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6777         else
6778             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6779         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
6780         LvTARGLEN(dstr) = LvTARGLEN(sstr);
6781         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
6782         LvTYPE(dstr)    = LvTYPE(sstr);
6783         break;
6784     case SVt_PVGV:
6785         SvANY(dstr)     = new_XPVGV();
6786         SvCUR(dstr)     = SvCUR(sstr);
6787         SvLEN(dstr)     = SvLEN(sstr);
6788         SvIVX(dstr)     = SvIVX(sstr);
6789         SvNVX(dstr)     = SvNVX(sstr);
6790         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6791         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6792         if (SvROK(sstr))
6793             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6794         else if (SvPVX(sstr) && SvLEN(sstr))
6795             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6796         else
6797             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6798         GvNAMELEN(dstr) = GvNAMELEN(sstr);
6799         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6800         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
6801         GvFLAGS(dstr)   = GvFLAGS(sstr);
6802         GvGP(dstr)      = gp_dup(GvGP(sstr));
6803         (void)GpREFCNT_inc(GvGP(dstr));
6804         break;
6805     case SVt_PVIO:
6806         SvANY(dstr)     = new_XPVIO();
6807         SvCUR(dstr)     = SvCUR(sstr);
6808         SvLEN(dstr)     = SvLEN(sstr);
6809         SvIVX(dstr)     = SvIVX(sstr);
6810         SvNVX(dstr)     = SvNVX(sstr);
6811         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6812         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6813         if (SvROK(sstr))
6814             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6815         else if (SvPVX(sstr) && SvLEN(sstr))
6816             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6817         else
6818             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6819         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6820         if (IoOFP(sstr) == IoIFP(sstr))
6821             IoOFP(dstr) = IoIFP(dstr);
6822         else
6823             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6824         /* PL_rsfp_filters entries have fake IoDIRP() */
6825         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6826             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
6827         else
6828             IoDIRP(dstr)        = IoDIRP(sstr);
6829         IoLINES(dstr)           = IoLINES(sstr);
6830         IoPAGE(dstr)            = IoPAGE(sstr);
6831         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
6832         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
6833         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
6834         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
6835         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
6836         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
6837         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
6838         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
6839         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
6840         IoTYPE(dstr)            = IoTYPE(sstr);
6841         IoFLAGS(dstr)           = IoFLAGS(sstr);
6842         break;
6843     case SVt_PVAV:
6844         SvANY(dstr)     = new_XPVAV();
6845         SvCUR(dstr)     = SvCUR(sstr);
6846         SvLEN(dstr)     = SvLEN(sstr);
6847         SvIVX(dstr)     = SvIVX(sstr);
6848         SvNVX(dstr)     = SvNVX(sstr);
6849         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6850         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6851         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6852         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6853         if (AvARRAY((AV*)sstr)) {
6854             SV **dst_ary, **src_ary;
6855             SSize_t items = AvFILLp((AV*)sstr) + 1;
6856
6857             src_ary = AvARRAY((AV*)sstr);
6858             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6859             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6860             SvPVX(dstr) = (char*)dst_ary;
6861             AvALLOC((AV*)dstr) = dst_ary;
6862             if (AvREAL((AV*)sstr)) {
6863                 while (items-- > 0)
6864                     *dst_ary++ = sv_dup_inc(*src_ary++);
6865             }
6866             else {
6867                 while (items-- > 0)
6868                     *dst_ary++ = sv_dup(*src_ary++);
6869             }
6870             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6871             while (items-- > 0) {
6872                 *dst_ary++ = &PL_sv_undef;
6873             }
6874         }
6875         else {
6876             SvPVX(dstr)         = Nullch;
6877             AvALLOC((AV*)dstr)  = (SV**)NULL;
6878         }
6879         break;
6880     case SVt_PVHV:
6881         SvANY(dstr)     = new_XPVHV();
6882         SvCUR(dstr)     = SvCUR(sstr);
6883         SvLEN(dstr)     = SvLEN(sstr);
6884         SvIVX(dstr)     = SvIVX(sstr);
6885         SvNVX(dstr)     = SvNVX(sstr);
6886         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6887         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6888         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
6889         if (HvARRAY((HV*)sstr)) {
6890             STRLEN i = 0;
6891             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6892             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6893             Newz(0, dxhv->xhv_array,
6894                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6895             while (i <= sxhv->xhv_max) {
6896                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6897                                                     !!HvSHAREKEYS(sstr));
6898                 ++i;
6899             }
6900             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6901         }
6902         else {
6903             SvPVX(dstr)         = Nullch;
6904             HvEITER((HV*)dstr)  = (HE*)NULL;
6905         }
6906         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
6907         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
6908         break;
6909     case SVt_PVFM:
6910         SvANY(dstr)     = new_XPVFM();
6911         FmLINES(dstr)   = FmLINES(sstr);
6912         goto dup_pvcv;
6913         /* NOTREACHED */
6914     case SVt_PVCV:
6915         SvANY(dstr)     = new_XPVCV();
6916 dup_pvcv:
6917         SvCUR(dstr)     = SvCUR(sstr);
6918         SvLEN(dstr)     = SvLEN(sstr);
6919         SvIVX(dstr)     = SvIVX(sstr);
6920         SvNVX(dstr)     = SvNVX(sstr);
6921         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6922         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6923         if (SvPVX(sstr) && SvLEN(sstr))
6924             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6925         else
6926             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6927         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6928         CvSTART(dstr)   = CvSTART(sstr);
6929         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
6930         CvXSUB(dstr)    = CvXSUB(sstr);
6931         CvXSUBANY(dstr) = CvXSUBANY(sstr);
6932         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
6933         CvDEPTH(dstr)   = CvDEPTH(sstr);
6934         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6935             /* XXX padlists are real, but pretend to be not */
6936             AvREAL_on(CvPADLIST(sstr));
6937             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6938             AvREAL_off(CvPADLIST(sstr));
6939             AvREAL_off(CvPADLIST(dstr));
6940         }
6941         else
6942             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6943         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6944         CvFLAGS(dstr)   = CvFLAGS(sstr);
6945         break;
6946     default:
6947         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6948         break;
6949     }
6950
6951     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6952         ++PL_sv_objcount;
6953
6954     return dstr;
6955 }
6956
6957 PERL_CONTEXT *
6958 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6959 {
6960     PERL_CONTEXT *ncxs;
6961
6962     if (!cxs)
6963         return (PERL_CONTEXT*)NULL;
6964
6965     /* look for it in the table first */
6966     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6967     if (ncxs)
6968         return ncxs;
6969
6970     /* create anew and remember what it is */
6971     Newz(56, ncxs, max + 1, PERL_CONTEXT);
6972     ptr_table_store(PL_ptr_table, cxs, ncxs);
6973
6974     while (ix >= 0) {
6975         PERL_CONTEXT *cx = &cxs[ix];
6976         PERL_CONTEXT *ncx = &ncxs[ix];
6977         ncx->cx_type    = cx->cx_type;
6978         if (CxTYPE(cx) == CXt_SUBST) {
6979             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6980         }
6981         else {
6982             ncx->blk_oldsp      = cx->blk_oldsp;
6983             ncx->blk_oldcop     = cx->blk_oldcop;
6984             ncx->blk_oldretsp   = cx->blk_oldretsp;
6985             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
6986             ncx->blk_oldscopesp = cx->blk_oldscopesp;
6987             ncx->blk_oldpm      = cx->blk_oldpm;
6988             ncx->blk_gimme      = cx->blk_gimme;
6989             switch (CxTYPE(cx)) {
6990             case CXt_SUB:
6991                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
6992                                            ? cv_dup_inc(cx->blk_sub.cv)
6993                                            : cv_dup(cx->blk_sub.cv));
6994                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
6995                                            ? av_dup_inc(cx->blk_sub.argarray)
6996                                            : Nullav);
6997                 ncx->blk_sub.savearray  = av_dup(cx->blk_sub.savearray);
6998                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
6999                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
7000                 ncx->blk_sub.lval       = cx->blk_sub.lval;
7001                 break;
7002             case CXt_EVAL:
7003                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7004                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7005                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7006                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7007                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text);
7008                 break;
7009             case CXt_LOOP:
7010                 ncx->blk_loop.label     = cx->blk_loop.label;
7011                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
7012                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
7013                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
7014                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
7015                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
7016                                            ? cx->blk_loop.iterdata
7017                                            : gv_dup((GV*)cx->blk_loop.iterdata));
7018                 ncx->blk_loop.oldcurpad
7019                     = (SV**)ptr_table_fetch(PL_ptr_table,
7020                                             cx->blk_loop.oldcurpad);
7021                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave);
7022                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval);
7023                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary);
7024                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
7025                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
7026                 break;
7027             case CXt_FORMAT:
7028                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv);
7029                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv);
7030                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv);
7031                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
7032                 break;
7033             case CXt_BLOCK:
7034             case CXt_NULL:
7035                 break;
7036             }
7037         }
7038         --ix;
7039     }
7040     return ncxs;
7041 }
7042
7043 PERL_SI *
7044 Perl_si_dup(pTHX_ PERL_SI *si)
7045 {
7046     PERL_SI *nsi;
7047
7048     if (!si)
7049         return (PERL_SI*)NULL;
7050
7051     /* look for it in the table first */
7052     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7053     if (nsi)
7054         return nsi;
7055
7056     /* create anew and remember what it is */
7057     Newz(56, nsi, 1, PERL_SI);
7058     ptr_table_store(PL_ptr_table, si, nsi);
7059
7060     nsi->si_stack       = av_dup_inc(si->si_stack);
7061     nsi->si_cxix        = si->si_cxix;
7062     nsi->si_cxmax       = si->si_cxmax;
7063     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7064     nsi->si_type        = si->si_type;
7065     nsi->si_prev        = si_dup(si->si_prev);
7066     nsi->si_next        = si_dup(si->si_next);
7067     nsi->si_markoff     = si->si_markoff;
7068
7069     return nsi;
7070 }
7071
7072 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
7073 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
7074 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
7075 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
7076 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
7077 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
7078 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
7079 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
7080 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
7081 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
7082 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7083 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7084
7085 /* XXXXX todo */
7086 #define pv_dup_inc(p)   SAVEPV(p)
7087 #define pv_dup(p)       SAVEPV(p)
7088 #define svp_dup_inc(p,pp)       any_dup(p,pp)
7089
7090 void *
7091 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7092 {
7093     void *ret;
7094
7095     if (!v)
7096         return (void*)NULL;
7097
7098     /* look for it in the table first */
7099     ret = ptr_table_fetch(PL_ptr_table, v);
7100     if (ret)
7101         return ret;
7102
7103     /* see if it is part of the interpreter structure */
7104     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7105         ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7106     else
7107         ret = v;
7108
7109     return ret;
7110 }
7111
7112 ANY *
7113 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7114 {
7115     ANY *ss     = proto_perl->Tsavestack;
7116     I32 ix      = proto_perl->Tsavestack_ix;
7117     I32 max     = proto_perl->Tsavestack_max;
7118     ANY *nss;
7119     SV *sv;
7120     GV *gv;
7121     AV *av;
7122     HV *hv;
7123     void* ptr;
7124     int intval;
7125     long longval;
7126     GP *gp;
7127     IV iv;
7128     I32 i;
7129     char *c;
7130     void (*dptr) (void*);
7131     void (*dxptr) (pTHXo_ void*);
7132     OP *o;
7133
7134     Newz(54, nss, max, ANY);
7135
7136     while (ix > 0) {
7137         i = POPINT(ss,ix);
7138         TOPINT(nss,ix) = i;
7139         switch (i) {
7140         case SAVEt_ITEM:                        /* normal string */
7141             sv = (SV*)POPPTR(ss,ix);
7142             TOPPTR(nss,ix) = sv_dup_inc(sv);
7143             sv = (SV*)POPPTR(ss,ix);
7144             TOPPTR(nss,ix) = sv_dup_inc(sv);
7145             break;
7146         case SAVEt_SV:                          /* scalar reference */
7147             sv = (SV*)POPPTR(ss,ix);
7148             TOPPTR(nss,ix) = sv_dup_inc(sv);
7149             gv = (GV*)POPPTR(ss,ix);
7150             TOPPTR(nss,ix) = gv_dup_inc(gv);
7151             break;
7152         case SAVEt_GENERIC_SVREF:               /* generic sv */
7153         case SAVEt_SVREF:                       /* scalar reference */
7154             sv = (SV*)POPPTR(ss,ix);
7155             TOPPTR(nss,ix) = sv_dup_inc(sv);
7156             ptr = POPPTR(ss,ix);
7157             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7158             break;
7159         case SAVEt_AV:                          /* array reference */
7160             av = (AV*)POPPTR(ss,ix);
7161             TOPPTR(nss,ix) = av_dup_inc(av);
7162             gv = (GV*)POPPTR(ss,ix);
7163             TOPPTR(nss,ix) = gv_dup(gv);
7164             break;
7165         case SAVEt_HV:                          /* hash reference */
7166             hv = (HV*)POPPTR(ss,ix);
7167             TOPPTR(nss,ix) = hv_dup_inc(hv);
7168             gv = (GV*)POPPTR(ss,ix);
7169             TOPPTR(nss,ix) = gv_dup(gv);
7170             break;
7171         case SAVEt_INT:                         /* int reference */
7172             ptr = POPPTR(ss,ix);
7173             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7174             intval = (int)POPINT(ss,ix);
7175             TOPINT(nss,ix) = intval;
7176             break;
7177         case SAVEt_LONG:                        /* long reference */
7178             ptr = POPPTR(ss,ix);
7179             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7180             longval = (long)POPLONG(ss,ix);
7181             TOPLONG(nss,ix) = longval;
7182             break;
7183         case SAVEt_I32:                         /* I32 reference */
7184         case SAVEt_I16:                         /* I16 reference */
7185         case SAVEt_I8:                          /* I8 reference */
7186             ptr = POPPTR(ss,ix);
7187             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7188             i = POPINT(ss,ix);
7189             TOPINT(nss,ix) = i;
7190             break;
7191         case SAVEt_IV:                          /* IV reference */
7192             ptr = POPPTR(ss,ix);
7193             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7194             iv = POPIV(ss,ix);
7195             TOPIV(nss,ix) = iv;
7196             break;
7197         case SAVEt_SPTR:                        /* SV* reference */
7198             ptr = POPPTR(ss,ix);
7199             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7200             sv = (SV*)POPPTR(ss,ix);
7201             TOPPTR(nss,ix) = sv_dup(sv);
7202             break;
7203         case SAVEt_VPTR:                        /* random* reference */
7204             ptr = POPPTR(ss,ix);
7205             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7206             ptr = POPPTR(ss,ix);
7207             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7208             break;
7209         case SAVEt_PPTR:                        /* char* reference */
7210             ptr = POPPTR(ss,ix);
7211             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7212             c = (char*)POPPTR(ss,ix);
7213             TOPPTR(nss,ix) = pv_dup(c);
7214             break;
7215         case SAVEt_HPTR:                        /* HV* reference */
7216             ptr = POPPTR(ss,ix);
7217             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7218             hv = (HV*)POPPTR(ss,ix);
7219             TOPPTR(nss,ix) = hv_dup(hv);
7220             break;
7221         case SAVEt_APTR:                        /* AV* reference */
7222             ptr = POPPTR(ss,ix);
7223             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7224             av = (AV*)POPPTR(ss,ix);
7225             TOPPTR(nss,ix) = av_dup(av);
7226             break;
7227         case SAVEt_NSTAB:
7228             gv = (GV*)POPPTR(ss,ix);
7229             TOPPTR(nss,ix) = gv_dup(gv);
7230             break;
7231         case SAVEt_GP:                          /* scalar reference */
7232             gp = (GP*)POPPTR(ss,ix);
7233             TOPPTR(nss,ix) = gp = gp_dup(gp);
7234             (void)GpREFCNT_inc(gp);
7235             gv = (GV*)POPPTR(ss,ix);
7236             TOPPTR(nss,ix) = gv_dup_inc(c);
7237             c = (char*)POPPTR(ss,ix);
7238             TOPPTR(nss,ix) = pv_dup(c);
7239             iv = POPIV(ss,ix);
7240             TOPIV(nss,ix) = iv;
7241             iv = POPIV(ss,ix);
7242             TOPIV(nss,ix) = iv;
7243             break;
7244         case SAVEt_FREESV:
7245             sv = (SV*)POPPTR(ss,ix);
7246             TOPPTR(nss,ix) = sv_dup_inc(sv);
7247             break;
7248         case SAVEt_FREEOP:
7249             ptr = POPPTR(ss,ix);
7250             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7251                 /* these are assumed to be refcounted properly */
7252                 switch (((OP*)ptr)->op_type) {
7253                 case OP_LEAVESUB:
7254                 case OP_LEAVESUBLV:
7255                 case OP_LEAVEEVAL:
7256                 case OP_LEAVE:
7257                 case OP_SCOPE:
7258                 case OP_LEAVEWRITE:
7259                     TOPPTR(nss,ix) = ptr;
7260                     o = (OP*)ptr;
7261                     OpREFCNT_inc(o);
7262                     break;
7263                 default:
7264                     TOPPTR(nss,ix) = Nullop;
7265                     break;
7266                 }
7267             }
7268             else
7269                 TOPPTR(nss,ix) = Nullop;
7270             break;
7271         case SAVEt_FREEPV:
7272             c = (char*)POPPTR(ss,ix);
7273             TOPPTR(nss,ix) = pv_dup_inc(c);
7274             break;
7275         case SAVEt_CLEARSV:
7276             longval = POPLONG(ss,ix);
7277             TOPLONG(nss,ix) = longval;
7278             break;
7279         case SAVEt_DELETE:
7280             hv = (HV*)POPPTR(ss,ix);
7281             TOPPTR(nss,ix) = hv_dup_inc(hv);
7282             c = (char*)POPPTR(ss,ix);
7283             TOPPTR(nss,ix) = pv_dup_inc(c);
7284             i = POPINT(ss,ix);
7285             TOPINT(nss,ix) = i;
7286             break;
7287         case SAVEt_DESTRUCTOR:
7288             ptr = POPPTR(ss,ix);
7289             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
7290             dptr = POPDPTR(ss,ix);
7291             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7292             break;
7293         case SAVEt_DESTRUCTOR_X:
7294             ptr = POPPTR(ss,ix);
7295             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
7296             dxptr = POPDXPTR(ss,ix);
7297             TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7298             break;
7299         case SAVEt_REGCONTEXT:
7300         case SAVEt_ALLOC:
7301             i = POPINT(ss,ix);
7302             TOPINT(nss,ix) = i;
7303             ix -= i;
7304             break;
7305         case SAVEt_STACK_POS:           /* Position on Perl stack */
7306             i = POPINT(ss,ix);
7307             TOPINT(nss,ix) = i;
7308             break;
7309         case SAVEt_AELEM:               /* array element */
7310             sv = (SV*)POPPTR(ss,ix);
7311             TOPPTR(nss,ix) = sv_dup_inc(sv);
7312             i = POPINT(ss,ix);
7313             TOPINT(nss,ix) = i;
7314             av = (AV*)POPPTR(ss,ix);
7315             TOPPTR(nss,ix) = av_dup_inc(av);
7316             break;
7317         case SAVEt_HELEM:               /* hash element */
7318             sv = (SV*)POPPTR(ss,ix);
7319             TOPPTR(nss,ix) = sv_dup_inc(sv);
7320             sv = (SV*)POPPTR(ss,ix);
7321             TOPPTR(nss,ix) = sv_dup_inc(sv);
7322             hv = (HV*)POPPTR(ss,ix);
7323             TOPPTR(nss,ix) = hv_dup_inc(hv);
7324             break;
7325         case SAVEt_OP:
7326             ptr = POPPTR(ss,ix);
7327             TOPPTR(nss,ix) = ptr;
7328             break;
7329         case SAVEt_HINTS:
7330             i = POPINT(ss,ix);
7331             TOPINT(nss,ix) = i;
7332             break;
7333         case SAVEt_COMPPAD:
7334             av = (AV*)POPPTR(ss,ix);
7335             TOPPTR(nss,ix) = av_dup(av);
7336             break;
7337         default:
7338             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7339         }
7340     }
7341
7342     return nss;
7343 }
7344
7345 #ifdef PERL_OBJECT
7346 #include "XSUB.h"
7347 #endif
7348
7349 PerlInterpreter *
7350 perl_clone(PerlInterpreter *proto_perl, UV flags)
7351 {
7352 #ifdef PERL_OBJECT
7353     CPerlObj *pPerl = (CPerlObj*)proto_perl;
7354 #endif
7355
7356 #ifdef PERL_IMPLICIT_SYS
7357     return perl_clone_using(proto_perl, flags,
7358                             proto_perl->IMem,
7359                             proto_perl->IMemShared,
7360                             proto_perl->IMemParse,
7361                             proto_perl->IEnv,
7362                             proto_perl->IStdIO,
7363                             proto_perl->ILIO,
7364                             proto_perl->IDir,
7365                             proto_perl->ISock,
7366                             proto_perl->IProc);
7367 }
7368
7369 PerlInterpreter *
7370 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7371                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
7372                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7373                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7374                  struct IPerlDir* ipD, struct IPerlSock* ipS,
7375                  struct IPerlProc* ipP)
7376 {
7377     /* XXX many of the string copies here can be optimized if they're
7378      * constants; they need to be allocated as common memory and just
7379      * their pointers copied. */
7380
7381     IV i;
7382 #  ifdef PERL_OBJECT
7383     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7384                                         ipD, ipS, ipP);
7385     PERL_SET_THX(pPerl);
7386 #  else         /* !PERL_OBJECT */
7387     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7388     PERL_SET_THX(my_perl);
7389
7390 #    ifdef DEBUGGING
7391     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7392     PL_markstack = 0;
7393     PL_scopestack = 0;
7394     PL_savestack = 0;
7395     PL_retstack = 0;
7396 #    else       /* !DEBUGGING */
7397     Zero(my_perl, 1, PerlInterpreter);
7398 #    endif      /* DEBUGGING */
7399
7400     /* host pointers */
7401     PL_Mem              = ipM;
7402     PL_MemShared        = ipMS;
7403     PL_MemParse         = ipMP;
7404     PL_Env              = ipE;
7405     PL_StdIO            = ipStd;
7406     PL_LIO              = ipLIO;
7407     PL_Dir              = ipD;
7408     PL_Sock             = ipS;
7409     PL_Proc             = ipP;
7410 #  endif        /* PERL_OBJECT */
7411 #else           /* !PERL_IMPLICIT_SYS */
7412     IV i;
7413     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7414     PERL_SET_THX(my_perl);
7415
7416 #    ifdef DEBUGGING
7417     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7418     PL_markstack = 0;
7419     PL_scopestack = 0;
7420     PL_savestack = 0;
7421     PL_retstack = 0;
7422 #    else       /* !DEBUGGING */
7423     Zero(my_perl, 1, PerlInterpreter);
7424 #    endif      /* DEBUGGING */
7425 #endif          /* PERL_IMPLICIT_SYS */
7426
7427     /* arena roots */
7428     PL_xiv_arenaroot    = NULL;
7429     PL_xiv_root         = NULL;
7430     PL_xnv_root         = NULL;
7431     PL_xrv_root         = NULL;
7432     PL_xpv_root         = NULL;
7433     PL_xpviv_root       = NULL;
7434     PL_xpvnv_root       = NULL;
7435     PL_xpvcv_root       = NULL;
7436     PL_xpvav_root       = NULL;
7437     PL_xpvhv_root       = NULL;
7438     PL_xpvmg_root       = NULL;
7439     PL_xpvlv_root       = NULL;
7440     PL_xpvbm_root       = NULL;
7441     PL_he_root          = NULL;
7442     PL_nice_chunk       = NULL;
7443     PL_nice_chunk_size  = 0;
7444     PL_sv_count         = 0;
7445     PL_sv_objcount      = 0;
7446     PL_sv_root          = Nullsv;
7447     PL_sv_arenaroot     = Nullsv;
7448
7449     PL_debug            = proto_perl->Idebug;
7450
7451     /* create SV map for pointer relocation */
7452     PL_ptr_table = ptr_table_new();
7453
7454     /* initialize these special pointers as early as possible */
7455     SvANY(&PL_sv_undef)         = NULL;
7456     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
7457     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
7458     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7459
7460 #ifdef PERL_OBJECT
7461     SvUPGRADE(&PL_sv_no, SVt_PVNV);
7462 #else
7463     SvANY(&PL_sv_no)            = new_XPVNV();
7464 #endif
7465     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
7466     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7467     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
7468     SvCUR(&PL_sv_no)            = 0;
7469     SvLEN(&PL_sv_no)            = 1;
7470     SvNVX(&PL_sv_no)            = 0;
7471     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7472
7473 #ifdef PERL_OBJECT
7474     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7475 #else
7476     SvANY(&PL_sv_yes)           = new_XPVNV();
7477 #endif
7478     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
7479     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7480     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
7481     SvCUR(&PL_sv_yes)           = 1;
7482     SvLEN(&PL_sv_yes)           = 2;
7483     SvNVX(&PL_sv_yes)           = 1;
7484     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7485
7486     /* create shared string table */
7487     PL_strtab           = newHV();
7488     HvSHAREKEYS_off(PL_strtab);
7489     hv_ksplit(PL_strtab, 512);
7490     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7491
7492     PL_compiling                = proto_perl->Icompiling;
7493     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
7494     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
7495     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7496     if (!specialWARN(PL_compiling.cop_warnings))
7497         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7498     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7499
7500     /* pseudo environmental stuff */
7501     PL_origargc         = proto_perl->Iorigargc;
7502     i = PL_origargc;
7503     New(0, PL_origargv, i+1, char*);
7504     PL_origargv[i] = '\0';
7505     while (i-- > 0) {
7506         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
7507     }
7508     PL_envgv            = gv_dup(proto_perl->Ienvgv);
7509     PL_incgv            = gv_dup(proto_perl->Iincgv);
7510     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
7511     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
7512     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
7513     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
7514
7515     /* switches */
7516     PL_minus_c          = proto_perl->Iminus_c;
7517     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
7518     PL_localpatches     = proto_perl->Ilocalpatches;
7519     PL_splitstr         = proto_perl->Isplitstr;
7520     PL_preprocess       = proto_perl->Ipreprocess;
7521     PL_minus_n          = proto_perl->Iminus_n;
7522     PL_minus_p          = proto_perl->Iminus_p;
7523     PL_minus_l          = proto_perl->Iminus_l;
7524     PL_minus_a          = proto_perl->Iminus_a;
7525     PL_minus_F          = proto_perl->Iminus_F;
7526     PL_doswitches       = proto_perl->Idoswitches;
7527     PL_dowarn           = proto_perl->Idowarn;
7528     PL_doextract        = proto_perl->Idoextract;
7529     PL_sawampersand     = proto_perl->Isawampersand;
7530     PL_unsafe           = proto_perl->Iunsafe;
7531     PL_inplace          = SAVEPV(proto_perl->Iinplace);
7532     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
7533     PL_perldb           = proto_perl->Iperldb;
7534     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7535
7536     /* magical thingies */
7537     /* XXX time(&PL_basetime) when asked for? */
7538     PL_basetime         = proto_perl->Ibasetime;
7539     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
7540
7541     PL_maxsysfd         = proto_perl->Imaxsysfd;
7542     PL_multiline        = proto_perl->Imultiline;
7543     PL_statusvalue      = proto_perl->Istatusvalue;
7544 #ifdef VMS
7545     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
7546 #endif
7547
7548     /* shortcuts to various I/O objects */
7549     PL_stdingv          = gv_dup(proto_perl->Istdingv);
7550     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
7551     PL_defgv            = gv_dup(proto_perl->Idefgv);
7552     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
7553     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
7554     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
7555
7556     /* shortcuts to regexp stuff */
7557     PL_replgv           = gv_dup(proto_perl->Ireplgv);
7558
7559     /* shortcuts to misc objects */
7560     PL_errgv            = gv_dup(proto_perl->Ierrgv);
7561
7562     /* shortcuts to debugging objects */
7563     PL_DBgv             = gv_dup(proto_perl->IDBgv);
7564     PL_DBline           = gv_dup(proto_perl->IDBline);
7565     PL_DBsub            = gv_dup(proto_perl->IDBsub);
7566     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
7567     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
7568     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
7569     PL_lineary          = av_dup(proto_perl->Ilineary);
7570     PL_dbargs           = av_dup(proto_perl->Idbargs);
7571
7572     /* symbol tables */
7573     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
7574     PL_curstash         = hv_dup(proto_perl->Tcurstash);
7575     PL_debstash         = hv_dup(proto_perl->Idebstash);
7576     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
7577     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
7578
7579     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
7580     PL_endav            = av_dup_inc(proto_perl->Iendav);
7581     PL_checkav          = av_dup_inc(proto_perl->Icheckav);
7582     PL_initav           = av_dup_inc(proto_perl->Iinitav);
7583
7584     PL_sub_generation   = proto_perl->Isub_generation;
7585
7586     /* funky return mechanisms */
7587     PL_forkprocess      = proto_perl->Iforkprocess;
7588
7589     /* subprocess state */
7590     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
7591
7592     /* internal state */
7593     PL_tainting         = proto_perl->Itainting;
7594     PL_maxo             = proto_perl->Imaxo;
7595     if (proto_perl->Iop_mask)
7596         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7597     else
7598         PL_op_mask      = Nullch;
7599
7600     /* current interpreter roots */
7601     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
7602     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
7603     PL_main_start       = proto_perl->Imain_start;
7604     PL_eval_root        = proto_perl->Ieval_root;
7605     PL_eval_start       = proto_perl->Ieval_start;
7606
7607     /* runtime control stuff */
7608     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7609     PL_copline          = proto_perl->Icopline;
7610
7611     PL_filemode         = proto_perl->Ifilemode;
7612     PL_lastfd           = proto_perl->Ilastfd;
7613     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
7614     PL_Argv             = NULL;
7615     PL_Cmd              = Nullch;
7616     PL_gensym           = proto_perl->Igensym;
7617     PL_preambled        = proto_perl->Ipreambled;
7618     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
7619     PL_laststatval      = proto_perl->Ilaststatval;
7620     PL_laststype        = proto_perl->Ilaststype;
7621     PL_mess_sv          = Nullsv;
7622
7623     PL_orslen           = proto_perl->Iorslen;
7624     PL_ors              = SAVEPVN(proto_perl->Iors, PL_orslen);
7625     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
7626
7627     /* interpreter atexit processing */
7628     PL_exitlistlen      = proto_perl->Iexitlistlen;
7629     if (PL_exitlistlen) {
7630         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7631         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7632     }
7633     else
7634         PL_exitlist     = (PerlExitListEntry*)NULL;
7635     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
7636
7637     PL_profiledata      = NULL;
7638     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
7639     /* PL_rsfp_filters entries have fake IoDIRP() */
7640     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
7641
7642     PL_compcv                   = cv_dup(proto_perl->Icompcv);
7643     PL_comppad                  = av_dup(proto_perl->Icomppad);
7644     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
7645     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
7646     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
7647     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
7648                                                         proto_perl->Tcurpad);
7649
7650 #ifdef HAVE_INTERP_INTERN
7651     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7652 #endif
7653
7654     /* more statics moved here */
7655     PL_generation       = proto_perl->Igeneration;
7656     PL_DBcv             = cv_dup(proto_perl->IDBcv);
7657
7658     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
7659     PL_in_clean_all     = proto_perl->Iin_clean_all;
7660
7661     PL_uid              = proto_perl->Iuid;
7662     PL_euid             = proto_perl->Ieuid;
7663     PL_gid              = proto_perl->Igid;
7664     PL_egid             = proto_perl->Iegid;
7665     PL_nomemok          = proto_perl->Inomemok;
7666     PL_an               = proto_perl->Ian;
7667     PL_cop_seqmax       = proto_perl->Icop_seqmax;
7668     PL_op_seqmax        = proto_perl->Iop_seqmax;
7669     PL_evalseq          = proto_perl->Ievalseq;
7670     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
7671     PL_origalen         = proto_perl->Iorigalen;
7672     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
7673     PL_osname           = SAVEPV(proto_perl->Iosname);
7674     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
7675     PL_sighandlerp      = proto_perl->Isighandlerp;
7676
7677
7678     PL_runops           = proto_perl->Irunops;
7679
7680     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7681
7682 #ifdef CSH
7683     PL_cshlen           = proto_perl->Icshlen;
7684     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7685 #endif
7686
7687     PL_lex_state        = proto_perl->Ilex_state;
7688     PL_lex_defer        = proto_perl->Ilex_defer;
7689     PL_lex_expect       = proto_perl->Ilex_expect;
7690     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
7691     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
7692     PL_lex_starts       = proto_perl->Ilex_starts;
7693     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
7694     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
7695     PL_lex_op           = proto_perl->Ilex_op;
7696     PL_lex_inpat        = proto_perl->Ilex_inpat;
7697     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
7698     PL_lex_brackets     = proto_perl->Ilex_brackets;
7699     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7700     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
7701     PL_lex_casemods     = proto_perl->Ilex_casemods;
7702     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7703     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
7704
7705     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7706     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7707     PL_nexttoke         = proto_perl->Inexttoke;
7708
7709     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
7710     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7711     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7712     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7713     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7714     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7715     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7716     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7717     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7718     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7719     PL_pending_ident    = proto_perl->Ipending_ident;
7720     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
7721
7722     PL_expect           = proto_perl->Iexpect;
7723
7724     PL_multi_start      = proto_perl->Imulti_start;
7725     PL_multi_end        = proto_perl->Imulti_end;
7726     PL_multi_open       = proto_perl->Imulti_open;
7727     PL_multi_close      = proto_perl->Imulti_close;
7728
7729     PL_error_count      = proto_perl->Ierror_count;
7730     PL_subline          = proto_perl->Isubline;
7731     PL_subname          = sv_dup_inc(proto_perl->Isubname);
7732
7733     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
7734     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
7735     PL_padix                    = proto_perl->Ipadix;
7736     PL_padix_floor              = proto_perl->Ipadix_floor;
7737     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
7738
7739     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7740     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7741     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7742     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7743     PL_last_lop_op      = proto_perl->Ilast_lop_op;
7744     PL_in_my            = proto_perl->Iin_my;
7745     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
7746 #ifdef FCRYPT
7747     PL_cryptseen        = proto_perl->Icryptseen;
7748 #endif
7749
7750     PL_hints            = proto_perl->Ihints;
7751
7752     PL_amagic_generation        = proto_perl->Iamagic_generation;
7753
7754 #ifdef USE_LOCALE_COLLATE
7755     PL_collation_ix     = proto_perl->Icollation_ix;
7756     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
7757     PL_collation_standard       = proto_perl->Icollation_standard;
7758     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
7759     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
7760 #endif /* USE_LOCALE_COLLATE */
7761
7762 #ifdef USE_LOCALE_NUMERIC
7763     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
7764     PL_numeric_standard = proto_perl->Inumeric_standard;
7765     PL_numeric_local    = proto_perl->Inumeric_local;
7766     PL_numeric_radix    = proto_perl->Inumeric_radix;
7767 #endif /* !USE_LOCALE_NUMERIC */
7768
7769     /* utf8 character classes */
7770     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
7771     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
7772     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
7773     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
7774     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
7775     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
7776     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
7777     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
7778     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
7779     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
7780     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
7781     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
7782     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
7783     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
7784     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
7785     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
7786     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
7787
7788     /* swatch cache */
7789     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
7790     PL_last_swash_klen  = 0;
7791     PL_last_swash_key[0]= '\0';
7792     PL_last_swash_tmps  = (U8*)NULL;
7793     PL_last_swash_slen  = 0;
7794
7795     /* perly.c globals */
7796     PL_yydebug          = proto_perl->Iyydebug;
7797     PL_yynerrs          = proto_perl->Iyynerrs;
7798     PL_yyerrflag        = proto_perl->Iyyerrflag;
7799     PL_yychar           = proto_perl->Iyychar;
7800     PL_yyval            = proto_perl->Iyyval;
7801     PL_yylval           = proto_perl->Iyylval;
7802
7803     PL_glob_index       = proto_perl->Iglob_index;
7804     PL_srand_called     = proto_perl->Isrand_called;
7805     PL_uudmap['M']      = 0;            /* reinits on demand */
7806     PL_bitcount         = Nullch;       /* reinits on demand */
7807
7808     if (proto_perl->Ipsig_ptr) {
7809         int sig_num[] = { SIG_NUM };
7810         Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7811         Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7812         for (i = 1; PL_sig_name[i]; i++) {
7813             PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7814             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7815         }
7816     }
7817     else {
7818         PL_psig_ptr     = (SV**)NULL;
7819         PL_psig_name    = (SV**)NULL;
7820     }
7821
7822     /* thrdvar.h stuff */
7823
7824     if (flags & 1) {
7825         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7826         PL_tmps_ix              = proto_perl->Ttmps_ix;
7827         PL_tmps_max             = proto_perl->Ttmps_max;
7828         PL_tmps_floor           = proto_perl->Ttmps_floor;
7829         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7830         i = 0;
7831         while (i <= PL_tmps_ix) {
7832             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7833             ++i;
7834         }
7835
7836         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7837         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7838         Newz(54, PL_markstack, i, I32);
7839         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
7840                                                   - proto_perl->Tmarkstack);
7841         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
7842                                                   - proto_perl->Tmarkstack);
7843         Copy(proto_perl->Tmarkstack, PL_markstack,
7844              PL_markstack_ptr - PL_markstack + 1, I32);
7845
7846         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7847          * NOTE: unlike the others! */
7848         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
7849         PL_scopestack_max       = proto_perl->Tscopestack_max;
7850         Newz(54, PL_scopestack, PL_scopestack_max, I32);
7851         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7852
7853         /* next push_return() sets PL_retstack[PL_retstack_ix]
7854          * NOTE: unlike the others! */
7855         PL_retstack_ix          = proto_perl->Tretstack_ix;
7856         PL_retstack_max         = proto_perl->Tretstack_max;
7857         Newz(54, PL_retstack, PL_retstack_max, OP*);
7858         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7859
7860         /* NOTE: si_dup() looks at PL_markstack */
7861         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
7862
7863         /* PL_curstack          = PL_curstackinfo->si_stack; */
7864         PL_curstack             = av_dup(proto_perl->Tcurstack);
7865         PL_mainstack            = av_dup(proto_perl->Tmainstack);
7866
7867         /* next PUSHs() etc. set *(PL_stack_sp+1) */
7868         PL_stack_base           = AvARRAY(PL_curstack);
7869         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
7870                                                    - proto_perl->Tstack_base);
7871         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
7872
7873         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7874          * NOTE: unlike the others! */
7875         PL_savestack_ix         = proto_perl->Tsavestack_ix;
7876         PL_savestack_max        = proto_perl->Tsavestack_max;
7877         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7878         PL_savestack            = ss_dup(proto_perl);
7879     }
7880     else {
7881         init_stacks();
7882         ENTER;                  /* perl_destruct() wants to LEAVE; */
7883     }
7884
7885     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
7886     PL_top_env          = &PL_start_env;
7887
7888     PL_op               = proto_perl->Top;
7889
7890     PL_Sv               = Nullsv;
7891     PL_Xpv              = (XPV*)NULL;
7892     PL_na               = proto_perl->Tna;
7893
7894     PL_statbuf          = proto_perl->Tstatbuf;
7895     PL_statcache        = proto_perl->Tstatcache;
7896     PL_statgv           = gv_dup(proto_perl->Tstatgv);
7897     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
7898 #ifdef HAS_TIMES
7899     PL_timesbuf         = proto_perl->Ttimesbuf;
7900 #endif
7901
7902     PL_tainted          = proto_perl->Ttainted;
7903     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
7904     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
7905     PL_rs               = sv_dup_inc(proto_perl->Trs);
7906     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
7907     PL_ofslen           = proto_perl->Tofslen;
7908     PL_ofs              = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7909     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
7910     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
7911     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
7912     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
7913     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
7914
7915     PL_restartop        = proto_perl->Trestartop;
7916     PL_in_eval          = proto_perl->Tin_eval;
7917     PL_delaymagic       = proto_perl->Tdelaymagic;
7918     PL_dirty            = proto_perl->Tdirty;
7919     PL_localizing       = proto_perl->Tlocalizing;
7920
7921 #ifdef PERL_FLEXIBLE_EXCEPTIONS
7922     PL_protect          = proto_perl->Tprotect;
7923 #endif
7924     PL_errors           = sv_dup_inc(proto_perl->Terrors);
7925     PL_av_fetch_sv      = Nullsv;
7926     PL_hv_fetch_sv      = Nullsv;
7927     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
7928     PL_modcount         = proto_perl->Tmodcount;
7929     PL_lastgotoprobe    = Nullop;
7930     PL_dumpindent       = proto_perl->Tdumpindent;
7931
7932     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7933     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
7934     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
7935     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
7936     PL_sortcxix         = proto_perl->Tsortcxix;
7937     PL_efloatbuf        = Nullch;               /* reinits on demand */
7938     PL_efloatsize       = 0;                    /* reinits on demand */
7939
7940     /* regex stuff */
7941
7942     PL_screamfirst      = NULL;
7943     PL_screamnext       = NULL;
7944     PL_maxscream        = -1;                   /* reinits on demand */
7945     PL_lastscream       = Nullsv;
7946
7947     PL_watchaddr        = NULL;
7948     PL_watchok          = Nullch;
7949
7950     PL_regdummy         = proto_perl->Tregdummy;
7951     PL_regcomp_parse    = Nullch;
7952     PL_regxend          = Nullch;
7953     PL_regcode          = (regnode*)NULL;
7954     PL_regnaughty       = 0;
7955     PL_regsawback       = 0;
7956     PL_regprecomp       = Nullch;
7957     PL_regnpar          = 0;
7958     PL_regsize          = 0;
7959     PL_regflags         = 0;
7960     PL_regseen          = 0;
7961     PL_seen_zerolen     = 0;
7962     PL_seen_evals       = 0;
7963     PL_regcomp_rx       = (regexp*)NULL;
7964     PL_extralen         = 0;
7965     PL_colorset         = 0;            /* reinits PL_colors[] */
7966     /*PL_colors[6]      = {0,0,0,0,0,0};*/
7967     PL_reg_whilem_seen  = 0;
7968     PL_reginput         = Nullch;
7969     PL_regbol           = Nullch;
7970     PL_regeol           = Nullch;
7971     PL_regstartp        = (I32*)NULL;
7972     PL_regendp          = (I32*)NULL;
7973     PL_reglastparen     = (U32*)NULL;
7974     PL_regtill          = Nullch;
7975     PL_regprev          = '\n';
7976     PL_reg_start_tmp    = (char**)NULL;
7977     PL_reg_start_tmpl   = 0;
7978     PL_regdata          = (struct reg_data*)NULL;
7979     PL_bostr            = Nullch;
7980     PL_reg_flags        = 0;
7981     PL_reg_eval_set     = 0;
7982     PL_regnarrate       = 0;
7983     PL_regprogram       = (regnode*)NULL;
7984     PL_regindent        = 0;
7985     PL_regcc            = (CURCUR*)NULL;
7986     PL_reg_call_cc      = (struct re_cc_state*)NULL;
7987     PL_reg_re           = (regexp*)NULL;
7988     PL_reg_ganch        = Nullch;
7989     PL_reg_sv           = Nullsv;
7990     PL_reg_magic        = (MAGIC*)NULL;
7991     PL_reg_oldpos       = 0;
7992     PL_reg_oldcurpm     = (PMOP*)NULL;
7993     PL_reg_curpm        = (PMOP*)NULL;
7994     PL_reg_oldsaved     = Nullch;
7995     PL_reg_oldsavedlen  = 0;
7996     PL_reg_maxiter      = 0;
7997     PL_reg_leftiter     = 0;
7998     PL_reg_poscache     = Nullch;
7999     PL_reg_poscache_size= 0;
8000
8001     /* RE engine - function pointers */
8002     PL_regcompp         = proto_perl->Tregcompp;
8003     PL_regexecp         = proto_perl->Tregexecp;
8004     PL_regint_start     = proto_perl->Tregint_start;
8005     PL_regint_string    = proto_perl->Tregint_string;
8006     PL_regfree          = proto_perl->Tregfree;
8007
8008     PL_reginterp_cnt    = 0;
8009     PL_reg_starttry     = 0;
8010
8011 #ifdef PERL_OBJECT
8012     return (PerlInterpreter*)pPerl;
8013 #else
8014     return my_perl;
8015 #endif
8016 }
8017
8018 #else   /* !USE_ITHREADS */
8019
8020 #ifdef PERL_OBJECT
8021 #include "XSUB.h"
8022 #endif
8023
8024 #endif /* USE_ITHREADS */
8025
8026 static void
8027 do_report_used(pTHXo_ SV *sv)
8028 {
8029     if (SvTYPE(sv) != SVTYPEMASK) {
8030         PerlIO_printf(Perl_debug_log, "****\n");
8031         sv_dump(sv);
8032     }
8033 }
8034
8035 static void
8036 do_clean_objs(pTHXo_ SV *sv)
8037 {
8038     SV* rv;
8039
8040     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8041         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8042         SvROK_off(sv);
8043         SvRV(sv) = 0;
8044         SvREFCNT_dec(rv);
8045     }
8046
8047     /* XXX Might want to check arrays, etc. */
8048 }
8049
8050 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8051 static void
8052 do_clean_named_objs(pTHXo_ SV *sv)
8053 {
8054     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8055         if ( SvOBJECT(GvSV(sv)) ||
8056              (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8057              (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8058              (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8059              (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8060         {
8061             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8062             SvREFCNT_dec(sv);
8063         }
8064     }
8065 }
8066 #endif
8067
8068 static void
8069 do_clean_all(pTHXo_ SV *sv)
8070 {
8071     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8072     SvFLAGS(sv) |= SVf_BREAK;
8073     SvREFCNT_dec(sv);
8074 }
8075