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