sv.c

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