sv.c

   1 /*    sv.c
   2  *
   3  *    Copyright (c) 1991-2000, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "I wonder what the Entish is for 'yes' and 'no'," he thought.
  12  */
  13
  14 #include "EXTERN.h"
  15 #define PERL_IN_SV_C
  16 #include "perl.h"
  17
  18 #define FCALL *f
  19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
  20
  21 static void do_report_used(pTHXo_ SV *sv);
  22 static void do_clean_objs(pTHXo_ SV *sv);
  23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
  24 static void do_clean_named_objs(pTHXo_ SV *sv);
  25 #endif
  26 static void do_clean_all(pTHXo_ SV *sv);
  27
  28 /*
  29  * "A time to plant, and a time to uproot what was planted..."
  30  */
  31
  32 #define plant_SV(p) \
  33     STMT_START {                                        \
  34         SvANY(p) = (void *)PL_sv_root;                  \
  35         SvFLAGS(p) = SVTYPEMASK;                        \
  36         PL_sv_root = (p);                               \
  37         --PL_sv_count;                                  \
  38     } STMT_END
  39
  40 /* sv_mutex must be held while calling uproot_SV() */
  41 #define uproot_SV(p) \
  42     STMT_START {                                        \
  43         (p) = PL_sv_root;                               \
  44         PL_sv_root = (SV*)SvANY(p);                     \
  45         ++PL_sv_count;                                  \
  46     } STMT_END
  47
  48 #define new_SV(p) \
  49     STMT_START {                                        \
  50         LOCK_SV_MUTEX;                                  \
  51         if (PL_sv_root)                                 \
  52             uproot_SV(p);                               \
  53         else                                            \
  54             (p) = more_sv();                            \
  55         UNLOCK_SV_MUTEX;                                \
  56         SvANY(p) = 0;                                   \
  57         SvREFCNT(p) = 1;                                \
  58         SvFLAGS(p) = 0;                                 \
  59     } STMT_END
  60
  61 #ifdef DEBUGGING
  62
  63 #define del_SV(p) \
  64     STMT_START {                                        \
  65         LOCK_SV_MUTEX;                                  \
  66         if (PL_debug & 32768)                           \
  67             del_sv(p);                                  \
  68         else                                            \
  69             plant_SV(p);                                \
  70         UNLOCK_SV_MUTEX;                                \
  71     } STMT_END
  72
  73 STATIC void
  74 S_del_sv(pTHX_ SV *p)
  75 {
  76     if (PL_debug & 32768) {
  77         SV* sva;
  78         SV* sv;
  79         SV* svend;
  80         int ok = 0;
  81         for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
  82             sv = sva + 1;
  83             svend = &sva[SvREFCNT(sva)];
  84             if (p >= sv && p < svend)
  85                 ok = 1;
  86         }
  87         if (!ok) {
  88             if (ckWARN_d(WARN_INTERNAL))
  89                 Perl_warner(aTHX_ WARN_INTERNAL,
  90                             "Attempt to free non-arena SV: 0x%"UVxf,
  91                             PTR2UV(p));
  92             return;
  93         }
  94     }
  95     plant_SV(p);
  96 }
  97
  98 #else /* ! DEBUGGING */
  99
 100 #define del_SV(p)   plant_SV(p)
 101
 102 #endif /* DEBUGGING */
 103
 104 void
 105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
 106 {
 107     SV* sva = (SV*)ptr;
 108     register SV* sv;
 109     register SV* svend;
 110     Zero(ptr, size, char);
 111
 112     /* The first SV in an arena isn't an SV. */
 113     SvANY(sva) = (void *) PL_sv_arenaroot;              /* ptr to next arena */
 114     SvREFCNT(sva) = size / sizeof(SV);          /* number of SV slots */
 115     SvFLAGS(sva) = flags;                       /* FAKE if not to be freed */
 116
 117     PL_sv_arenaroot = sva;
 118     PL_sv_root = sva + 1;
 119
 120     svend = &sva[SvREFCNT(sva) - 1];
 121     sv = sva + 1;
 122     while (sv < svend) {
 123         SvANY(sv) = (void *)(SV*)(sv + 1);
 124         SvFLAGS(sv) = SVTYPEMASK;
 125         sv++;
 126     }
 127     SvANY(sv) = 0;
 128     SvFLAGS(sv) = SVTYPEMASK;
 129 }
 130
 131 /* sv_mutex must be held while calling more_sv() */
 132 STATIC SV*
 133 S_more_sv(pTHX)
 134 {
 135     register SV* sv;
 136
 137     if (PL_nice_chunk) {
 138         sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
 139         PL_nice_chunk = Nullch;
 140     }
 141     else {
 142         char *chunk;                /* must use New here to match call to */
 143         New(704,chunk,1008,char);   /* Safefree() in sv_free_arenas()     */
 144         sv_add_arena(chunk, 1008, 0);
 145     }
 146     uproot_SV(sv);
 147     return sv;
 148 }
 149
 150 STATIC void
 151 S_visit(pTHX_ SVFUNC_t f)
 152 {
 153     SV* sva;
 154     SV* sv;
 155     register SV* svend;
 156
 157     for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
 158         svend = &sva[SvREFCNT(sva)];
 159         for (sv = sva + 1; sv < svend; ++sv) {
 160             if (SvTYPE(sv) != SVTYPEMASK)
 161                 (FCALL)(aTHXo_ sv);
 162         }
 163     }
 164 }
 165
 166 void
 167 Perl_sv_report_used(pTHX)
 168 {
 169     visit(do_report_used);
 170 }
 171
 172 void
 173 Perl_sv_clean_objs(pTHX)
 174 {
 175     PL_in_clean_objs = TRUE;
 176     visit(do_clean_objs);
 177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
 178     /* some barnacles may yet remain, clinging to typeglobs */
 179     visit(do_clean_named_objs);
 180 #endif
 181     PL_in_clean_objs = FALSE;
 182 }
 183
 184 void
 185 Perl_sv_clean_all(pTHX)
 186 {
 187     PL_in_clean_all = TRUE;
 188     visit(do_clean_all);
 189     PL_in_clean_all = FALSE;
 190 }
 191
 192 void
 193 Perl_sv_free_arenas(pTHX)
 194 {
 195     SV* sva;
 196     SV* svanext;
 197
 198     /* Free arenas here, but be careful about fake ones.  (We assume
 199        contiguity of the fake ones with the corresponding real ones.) */
 200
 201     for (sva = PL_sv_arenaroot; sva; sva = svanext) {
 202         svanext = (SV*) SvANY(sva);
 203         while (svanext && SvFAKE(svanext))
 204             svanext = (SV*) SvANY(svanext);
 205
 206         if (!SvFAKE(sva))
 207             Safefree((void *)sva);
 208     }
 209
 210     if (PL_nice_chunk)
 211         Safefree(PL_nice_chunk);
 212     PL_nice_chunk = Nullch;
 213     PL_nice_chunk_size = 0;
 214     PL_sv_arenaroot = 0;
 215     PL_sv_root = 0;
 216 }
 217
 218 void
 219 Perl_report_uninit(pTHX)
 220 {
 221     if (PL_op)
 222         Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
 223                     " in ", PL_op_desc[PL_op->op_type]);
 224     else
 225         Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
 226 }
 227
 228 STATIC XPVIV*
 229 S_new_xiv(pTHX)
 230 {
 231     IV* xiv;
 232     LOCK_SV_MUTEX;
 233     if (!PL_xiv_root)
 234         more_xiv();
 235     xiv = PL_xiv_root;
 236     /*
 237      * See comment in more_xiv() -- RAM.
 238      */
 239     PL_xiv_root = *(IV**)xiv;
 240     UNLOCK_SV_MUTEX;
 241     return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
 242 }
 243
 244 STATIC void
 245 S_del_xiv(pTHX_ XPVIV *p)
 246 {
 247     IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
 248     LOCK_SV_MUTEX;
 249     *(IV**)xiv = PL_xiv_root;
 250     PL_xiv_root = xiv;
 251     UNLOCK_SV_MUTEX;
 252 }
 253
 254 STATIC void
 255 S_more_xiv(pTHX)
 256 {
 257     register IV* xiv;
 258     register IV* xivend;
 259     XPV* ptr;
 260     New(705, ptr, 1008/sizeof(XPV), XPV);
 261     ptr->xpv_pv = (char*)PL_xiv_arenaroot;              /* linked list of xiv arenas */
 262     PL_xiv_arenaroot = ptr;                     /* to keep Purify happy */
 263
 264     xiv = (IV*) ptr;
 265     xivend = &xiv[1008 / sizeof(IV) - 1];
 266     xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1;   /* fudge by size of XPV */
 267     PL_xiv_root = xiv;
 268     while (xiv < xivend) {
 269         *(IV**)xiv = (IV *)(xiv + 1);
 270         xiv++;
 271     }
 272     *(IV**)xiv = 0;
 273 }
 274
 275 STATIC XPVNV*
 276 S_new_xnv(pTHX)
 277 {
 278     NV* xnv;
 279     LOCK_SV_MUTEX;
 280     if (!PL_xnv_root)
 281         more_xnv();
 282     xnv = PL_xnv_root;
 283     PL_xnv_root = *(NV**)xnv;
 284     UNLOCK_SV_MUTEX;
 285     return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
 286 }
 287
 288 STATIC void
 289 S_del_xnv(pTHX_ XPVNV *p)
 290 {
 291     NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
 292     LOCK_SV_MUTEX;
 293     *(NV**)xnv = PL_xnv_root;
 294     PL_xnv_root = xnv;
 295     UNLOCK_SV_MUTEX;
 296 }
 297
 298 STATIC void
 299 S_more_xnv(pTHX)
 300 {
 301     register NV* xnv;
 302     register NV* xnvend;
 303     New(711, xnv, 1008/sizeof(NV), NV);
 304     xnvend = &xnv[1008 / sizeof(NV) - 1];
 305     xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
 306     PL_xnv_root = xnv;
 307     while (xnv < xnvend) {
 308         *(NV**)xnv = (NV*)(xnv + 1);
 309         xnv++;
 310     }
 311     *(NV**)xnv = 0;
 312 }
 313
 314 STATIC XRV*
 315 S_new_xrv(pTHX)
 316 {
 317     XRV* xrv;
 318     LOCK_SV_MUTEX;
 319     if (!PL_xrv_root)
 320         more_xrv();
 321     xrv = PL_xrv_root;
 322     PL_xrv_root = (XRV*)xrv->xrv_rv;
 323     UNLOCK_SV_MUTEX;
 324     return xrv;
 325 }
 326
 327 STATIC void
 328 S_del_xrv(pTHX_ XRV *p)
 329 {
 330     LOCK_SV_MUTEX;
 331     p->xrv_rv = (SV*)PL_xrv_root;
 332     PL_xrv_root = p;
 333     UNLOCK_SV_MUTEX;
 334 }
 335
 336 STATIC void
 337 S_more_xrv(pTHX)
 338 {
 339     register XRV* xrv;
 340     register XRV* xrvend;
 341     New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
 342     xrv = PL_xrv_root;
 343     xrvend = &xrv[1008 / sizeof(XRV) - 1];
 344     while (xrv < xrvend) {
 345         xrv->xrv_rv = (SV*)(xrv + 1);
 346         xrv++;
 347     }
 348     xrv->xrv_rv = 0;
 349 }
 350
 351 STATIC XPV*
 352 S_new_xpv(pTHX)
 353 {
 354     XPV* xpv;
 355     LOCK_SV_MUTEX;
 356     if (!PL_xpv_root)
 357         more_xpv();
 358     xpv = PL_xpv_root;
 359     PL_xpv_root = (XPV*)xpv->xpv_pv;
 360     UNLOCK_SV_MUTEX;
 361     return xpv;
 362 }
 363
 364 STATIC void
 365 S_del_xpv(pTHX_ XPV *p)
 366 {
 367     LOCK_SV_MUTEX;
 368     p->xpv_pv = (char*)PL_xpv_root;
 369     PL_xpv_root = p;
 370     UNLOCK_SV_MUTEX;
 371 }
 372
 373 STATIC void
 374 S_more_xpv(pTHX)
 375 {
 376     register XPV* xpv;
 377     register XPV* xpvend;
 378     New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
 379     xpv = PL_xpv_root;
 380     xpvend = &xpv[1008 / sizeof(XPV) - 1];
 381     while (xpv < xpvend) {
 382         xpv->xpv_pv = (char*)(xpv + 1);
 383         xpv++;
 384     }
 385     xpv->xpv_pv = 0;
 386 }
 387
 388 STATIC XPVIV*
 389 S_new_xpviv(pTHX)
 390 {
 391     XPVIV* xpviv;
 392     LOCK_SV_MUTEX;
 393     if (!PL_xpviv_root)
 394         more_xpviv();
 395     xpviv = PL_xpviv_root;
 396     PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
 397     UNLOCK_SV_MUTEX;
 398     return xpviv;
 399 }
 400
 401 STATIC void
 402 S_del_xpviv(pTHX_ XPVIV *p)
 403 {
 404     LOCK_SV_MUTEX;
 405     p->xpv_pv = (char*)PL_xpviv_root;
 406     PL_xpviv_root = p;
 407     UNLOCK_SV_MUTEX;
 408 }
 409
 410
 411 STATIC void
 412 S_more_xpviv(pTHX)
 413 {
 414     register XPVIV* xpviv;
 415     register XPVIV* xpvivend;
 416     New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
 417     xpviv = PL_xpviv_root;
 418     xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
 419     while (xpviv < xpvivend) {
 420         xpviv->xpv_pv = (char*)(xpviv + 1);
 421         xpviv++;
 422     }
 423     xpviv->xpv_pv = 0;
 424 }
 425
 426
 427 STATIC XPVNV*
 428 S_new_xpvnv(pTHX)
 429 {
 430     XPVNV* xpvnv;
 431     LOCK_SV_MUTEX;
 432     if (!PL_xpvnv_root)
 433         more_xpvnv();
 434     xpvnv = PL_xpvnv_root;
 435     PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
 436     UNLOCK_SV_MUTEX;
 437     return xpvnv;
 438 }
 439
 440 STATIC void
 441 S_del_xpvnv(pTHX_ XPVNV *p)
 442 {
 443     LOCK_SV_MUTEX;
 444     p->xpv_pv = (char*)PL_xpvnv_root;
 445     PL_xpvnv_root = p;
 446     UNLOCK_SV_MUTEX;
 447 }
 448
 449
 450 STATIC void
 451 S_more_xpvnv(pTHX)
 452 {
 453     register XPVNV* xpvnv;
 454     register XPVNV* xpvnvend;
 455     New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
 456     xpvnv = PL_xpvnv_root;
 457     xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
 458     while (xpvnv < xpvnvend) {
 459         xpvnv->xpv_pv = (char*)(xpvnv + 1);
 460         xpvnv++;
 461     }
 462     xpvnv->xpv_pv = 0;
 463 }
 464
 465
 466
 467 STATIC XPVCV*
 468 S_new_xpvcv(pTHX)
 469 {
 470     XPVCV* xpvcv;
 471     LOCK_SV_MUTEX;
 472     if (!PL_xpvcv_root)
 473         more_xpvcv();
 474     xpvcv = PL_xpvcv_root;
 475     PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
 476     UNLOCK_SV_MUTEX;
 477     return xpvcv;
 478 }
 479
 480 STATIC void
 481 S_del_xpvcv(pTHX_ XPVCV *p)
 482 {
 483     LOCK_SV_MUTEX;
 484     p->xpv_pv = (char*)PL_xpvcv_root;
 485     PL_xpvcv_root = p;
 486     UNLOCK_SV_MUTEX;
 487 }
 488
 489
 490 STATIC void
 491 S_more_xpvcv(pTHX)
 492 {
 493     register XPVCV* xpvcv;
 494     register XPVCV* xpvcvend;
 495     New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
 496     xpvcv = PL_xpvcv_root;
 497     xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
 498     while (xpvcv < xpvcvend) {
 499         xpvcv->xpv_pv = (char*)(xpvcv + 1);
 500         xpvcv++;
 501     }
 502     xpvcv->xpv_pv = 0;
 503 }
 504
 505
 506
 507 STATIC XPVAV*
 508 S_new_xpvav(pTHX)
 509 {
 510     XPVAV* xpvav;
 511     LOCK_SV_MUTEX;
 512     if (!PL_xpvav_root)
 513         more_xpvav();
 514     xpvav = PL_xpvav_root;
 515     PL_xpvav_root = (XPVAV*)xpvav->xav_array;
 516     UNLOCK_SV_MUTEX;
 517     return xpvav;
 518 }
 519
 520 STATIC void
 521 S_del_xpvav(pTHX_ XPVAV *p)
 522 {
 523     LOCK_SV_MUTEX;
 524     p->xav_array = (char*)PL_xpvav_root;
 525     PL_xpvav_root = p;
 526     UNLOCK_SV_MUTEX;
 527 }
 528
 529
 530 STATIC void
 531 S_more_xpvav(pTHX)
 532 {
 533     register XPVAV* xpvav;
 534     register XPVAV* xpvavend;
 535     New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
 536     xpvav = PL_xpvav_root;
 537     xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
 538     while (xpvav < xpvavend) {
 539         xpvav->xav_array = (char*)(xpvav + 1);
 540         xpvav++;
 541     }
 542     xpvav->xav_array = 0;
 543 }
 544
 545
 546
 547 STATIC XPVHV*
 548 S_new_xpvhv(pTHX)
 549 {
 550     XPVHV* xpvhv;
 551     LOCK_SV_MUTEX;
 552     if (!PL_xpvhv_root)
 553         more_xpvhv();
 554     xpvhv = PL_xpvhv_root;
 555     PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
 556     UNLOCK_SV_MUTEX;
 557     return xpvhv;
 558 }
 559
 560 STATIC void
 561 S_del_xpvhv(pTHX_ XPVHV *p)
 562 {
 563     LOCK_SV_MUTEX;
 564     p->xhv_array = (char*)PL_xpvhv_root;
 565     PL_xpvhv_root = p;
 566     UNLOCK_SV_MUTEX;
 567 }
 568
 569
 570 STATIC void
 571 S_more_xpvhv(pTHX)
 572 {
 573     register XPVHV* xpvhv;
 574     register XPVHV* xpvhvend;
 575     New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
 576     xpvhv = PL_xpvhv_root;
 577     xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
 578     while (xpvhv < xpvhvend) {
 579         xpvhv->xhv_array = (char*)(xpvhv + 1);
 580         xpvhv++;
 581     }
 582     xpvhv->xhv_array = 0;
 583 }
 584
 585
 586 STATIC XPVMG*
 587 S_new_xpvmg(pTHX)
 588 {
 589     XPVMG* xpvmg;
 590     LOCK_SV_MUTEX;
 591     if (!PL_xpvmg_root)
 592         more_xpvmg();
 593     xpvmg = PL_xpvmg_root;
 594     PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
 595     UNLOCK_SV_MUTEX;
 596     return xpvmg;
 597 }
 598
 599 STATIC void
 600 S_del_xpvmg(pTHX_ XPVMG *p)
 601 {
 602     LOCK_SV_MUTEX;
 603     p->xpv_pv = (char*)PL_xpvmg_root;
 604     PL_xpvmg_root = p;
 605     UNLOCK_SV_MUTEX;
 606 }
 607
 608
 609 STATIC void
 610 S_more_xpvmg(pTHX)
 611 {
 612     register XPVMG* xpvmg;
 613     register XPVMG* xpvmgend;
 614     New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
 615     xpvmg = PL_xpvmg_root;
 616     xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
 617     while (xpvmg < xpvmgend) {
 618         xpvmg->xpv_pv = (char*)(xpvmg + 1);
 619         xpvmg++;
 620     }
 621     xpvmg->xpv_pv = 0;
 622 }
 623
 624
 625
 626 STATIC XPVLV*
 627 S_new_xpvlv(pTHX)
 628 {
 629     XPVLV* xpvlv;
 630     LOCK_SV_MUTEX;
 631     if (!PL_xpvlv_root)
 632         more_xpvlv();
 633     xpvlv = PL_xpvlv_root;
 634     PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
 635     UNLOCK_SV_MUTEX;
 636     return xpvlv;
 637 }
 638
 639 STATIC void
 640 S_del_xpvlv(pTHX_ XPVLV *p)
 641 {
 642     LOCK_SV_MUTEX;
 643     p->xpv_pv = (char*)PL_xpvlv_root;
 644     PL_xpvlv_root = p;
 645     UNLOCK_SV_MUTEX;
 646 }
 647
 648
 649 STATIC void
 650 S_more_xpvlv(pTHX)
 651 {
 652     register XPVLV* xpvlv;
 653     register XPVLV* xpvlvend;
 654     New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
 655     xpvlv = PL_xpvlv_root;
 656     xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
 657     while (xpvlv < xpvlvend) {
 658         xpvlv->xpv_pv = (char*)(xpvlv + 1);
 659         xpvlv++;
 660     }
 661     xpvlv->xpv_pv = 0;
 662 }
 663
 664
 665 STATIC XPVBM*
 666 S_new_xpvbm(pTHX)
 667 {
 668     XPVBM* xpvbm;
 669     LOCK_SV_MUTEX;
 670     if (!PL_xpvbm_root)
 671         more_xpvbm();
 672     xpvbm = PL_xpvbm_root;
 673     PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
 674     UNLOCK_SV_MUTEX;
 675     return xpvbm;
 676 }
 677
 678 STATIC void
 679 S_del_xpvbm(pTHX_ XPVBM *p)
 680 {
 681     LOCK_SV_MUTEX;
 682     p->xpv_pv = (char*)PL_xpvbm_root;
 683     PL_xpvbm_root = p;
 684     UNLOCK_SV_MUTEX;
 685 }
 686
 687
 688 STATIC void
 689 S_more_xpvbm(pTHX)
 690 {
 691     register XPVBM* xpvbm;
 692     register XPVBM* xpvbmend;
 693     New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
 694     xpvbm = PL_xpvbm_root;
 695     xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
 696     while (xpvbm < xpvbmend) {
 697         xpvbm->xpv_pv = (char*)(xpvbm + 1);
 698         xpvbm++;
 699     }
 700     xpvbm->xpv_pv = 0;
 701 }
 702
 703 #ifdef LEAKTEST
 704 #  define my_safemalloc(s)      (void*)safexmalloc(717,s)
 705 #  define my_safefree(p)        safexfree((char*)p)
 706 #else
 707 #  define my_safemalloc(s)      (void*)safemalloc(s)
 708 #  define my_safefree(p)        safefree((char*)p)
 709 #endif
 710
 711 #ifdef PURIFY
 712
 713 #define new_XIV()       my_safemalloc(sizeof(XPVIV))
 714 #define del_XIV(p)      my_safefree(p)
 715
 716 #define new_XNV()       my_safemalloc(sizeof(XPVNV))
 717 #define del_XNV(p)      my_safefree(p)
 718
 719 #define new_XRV()       my_safemalloc(sizeof(XRV))
 720 #define del_XRV(p)      my_safefree(p)
 721
 722 #define new_XPV()       my_safemalloc(sizeof(XPV))
 723 #define del_XPV(p)      my_safefree(p)
 724
 725 #define new_XPVIV()     my_safemalloc(sizeof(XPVIV))
 726 #define del_XPVIV(p)    my_safefree(p)
 727
 728 #define new_XPVNV()     my_safemalloc(sizeof(XPVNV))
 729 #define del_XPVNV(p)    my_safefree(p)
 730
 731 #define new_XPVCV()     my_safemalloc(sizeof(XPVCV))
 732 #define del_XPVCV(p)    my_safefree(p)
 733
 734 #define new_XPVAV()     my_safemalloc(sizeof(XPVAV))
 735 #define del_XPVAV(p)    my_safefree(p)
 736
 737 #define new_XPVHV()     my_safemalloc(sizeof(XPVHV))
 738 #define del_XPVHV(p)    my_safefree(p)
 739
 740 #define new_XPVMG()     my_safemalloc(sizeof(XPVMG))
 741 #define del_XPVMG(p)    my_safefree(p)
 742
 743 #define new_XPVLV()     my_safemalloc(sizeof(XPVLV))
 744 #define del_XPVLV(p)    my_safefree(p)
 745
 746 #define new_XPVBM()     my_safemalloc(sizeof(XPVBM))
 747 #define del_XPVBM(p)    my_safefree(p)
 748
 749 #else /* !PURIFY */
 750
 751 #define new_XIV()       (void*)new_xiv()
 752 #define del_XIV(p)      del_xiv((XPVIV*) p)
 753
 754 #define new_XNV()       (void*)new_xnv()
 755 #define del_XNV(p)      del_xnv((XPVNV*) p)
 756
 757 #define new_XRV()       (void*)new_xrv()
 758 #define del_XRV(p)      del_xrv((XRV*) p)
 759
 760 #define new_XPV()       (void*)new_xpv()
 761 #define del_XPV(p)      del_xpv((XPV *)p)
 762
 763 #define new_XPVIV()     (void*)new_xpviv()
 764 #define del_XPVIV(p)    del_xpviv((XPVIV *)p)
 765
 766 #define new_XPVNV()     (void*)new_xpvnv()
 767 #define del_XPVNV(p)    del_xpvnv((XPVNV *)p)
 768
 769 #define new_XPVCV()     (void*)new_xpvcv()
 770 #define del_XPVCV(p)    del_xpvcv((XPVCV *)p)
 771
 772 #define new_XPVAV()     (void*)new_xpvav()
 773 #define del_XPVAV(p)    del_xpvav((XPVAV *)p)
 774
 775 #define new_XPVHV()     (void*)new_xpvhv()
 776 #define del_XPVHV(p)    del_xpvhv((XPVHV *)p)
 777
 778 #define new_XPVMG()     (void*)new_xpvmg()
 779 #define del_XPVMG(p)    del_xpvmg((XPVMG *)p)
 780
 781 #define new_XPVLV()     (void*)new_xpvlv()
 782 #define del_XPVLV(p)    del_xpvlv((XPVLV *)p)
 783
 784 #define new_XPVBM()     (void*)new_xpvbm()
 785 #define del_XPVBM(p)    del_xpvbm((XPVBM *)p)
 786
 787 #endif /* PURIFY */
 788
 789 #define new_XPVGV()     my_safemalloc(sizeof(XPVGV))
 790 #define del_XPVGV(p)    my_safefree(p)
 791
 792 #define new_XPVFM()     my_safemalloc(sizeof(XPVFM))
 793 #define del_XPVFM(p)    my_safefree(p)
 794
 795 #define new_XPVIO()     my_safemalloc(sizeof(XPVIO))
 796 #define del_XPVIO(p)    my_safefree(p)
 797
 798 /*
 799 =for apidoc sv_upgrade
 800
 801 Upgrade an SV to a more complex form.  Use C<SvUPGRADE>.  See
 802 C<svtype>.
 803
 804 =cut
 805 */
 806
 807 bool
 808 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
 809 {
 810     char*       pv;
 811     U32         cur;
 812     U32         len;
 813     IV          iv;
 814     NV          nv;
 815     MAGIC*      magic;
 816     HV*         stash;
 817
 818     if (SvTYPE(sv) == mt)
 819         return TRUE;
 820
 821     if (mt < SVt_PVIV)
 822         (void)SvOOK_off(sv);
 823
 824     switch (SvTYPE(sv)) {
 825     case SVt_NULL:
 826         pv      = 0;
 827         cur     = 0;
 828         len     = 0;
 829         iv      = 0;
 830         nv      = 0.0;
 831         magic   = 0;
 832         stash   = 0;
 833         break;
 834     case SVt_IV:
 835         pv      = 0;
 836         cur     = 0;
 837         len     = 0;
 838         iv      = SvIVX(sv);
 839         nv      = (NV)SvIVX(sv);
 840         del_XIV(SvANY(sv));
 841         magic   = 0;
 842         stash   = 0;
 843         if (mt == SVt_NV)
 844             mt = SVt_PVNV;
 845         else if (mt < SVt_PVIV)
 846             mt = SVt_PVIV;
 847         break;
 848     case SVt_NV:
 849         pv      = 0;
 850         cur     = 0;
 851         len     = 0;
 852         nv      = SvNVX(sv);
 853         iv      = I_V(nv);
 854         magic   = 0;
 855         stash   = 0;
 856         del_XNV(SvANY(sv));
 857         SvANY(sv) = 0;
 858         if (mt < SVt_PVNV)
 859             mt = SVt_PVNV;
 860         break;
 861     case SVt_RV:
 862         pv      = (char*)SvRV(sv);
 863         cur     = 0;
 864         len     = 0;
 865         iv      = PTR2IV(pv);
 866         nv      = PTR2NV(pv);
 867         del_XRV(SvANY(sv));
 868         magic   = 0;
 869         stash   = 0;
 870         break;
 871     case SVt_PV:
 872         pv      = SvPVX(sv);
 873         cur     = SvCUR(sv);
 874         len     = SvLEN(sv);
 875         iv      = 0;
 876         nv      = 0.0;
 877         magic   = 0;
 878         stash   = 0;
 879         del_XPV(SvANY(sv));
 880         if (mt <= SVt_IV)
 881             mt = SVt_PVIV;
 882         else if (mt == SVt_NV)
 883             mt = SVt_PVNV;
 884         break;
 885     case SVt_PVIV:
 886         pv      = SvPVX(sv);
 887         cur     = SvCUR(sv);
 888         len     = SvLEN(sv);
 889         iv      = SvIVX(sv);
 890         nv      = 0.0;
 891         magic   = 0;
 892         stash   = 0;
 893         del_XPVIV(SvANY(sv));
 894         break;
 895     case SVt_PVNV:
 896         pv      = SvPVX(sv);
 897         cur     = SvCUR(sv);
 898         len     = SvLEN(sv);
 899         iv      = SvIVX(sv);
 900         nv      = SvNVX(sv);
 901         magic   = 0;
 902         stash   = 0;
 903         del_XPVNV(SvANY(sv));
 904         break;
 905     case SVt_PVMG:
 906         pv      = SvPVX(sv);
 907         cur     = SvCUR(sv);
 908         len     = SvLEN(sv);
 909         iv      = SvIVX(sv);
 910         nv      = SvNVX(sv);
 911         magic   = SvMAGIC(sv);
 912         stash   = SvSTASH(sv);
 913         del_XPVMG(SvANY(sv));
 914         break;
 915     default:
 916         Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
 917     }
 918
 919     switch (mt) {
 920     case SVt_NULL:
 921         Perl_croak(aTHX_ "Can't upgrade to undef");
 922     case SVt_IV:
 923         SvANY(sv) = new_XIV();
 924         SvIVX(sv)       = iv;
 925         break;
 926     case SVt_NV:
 927         SvANY(sv) = new_XNV();
 928         SvNVX(sv)       = nv;
 929         break;
 930     case SVt_RV:
 931         SvANY(sv) = new_XRV();
 932         SvRV(sv) = (SV*)pv;
 933         break;
 934     case SVt_PV:
 935         SvANY(sv) = new_XPV();
 936         SvPVX(sv)       = pv;
 937         SvCUR(sv)       = cur;
 938         SvLEN(sv)       = len;
 939         break;
 940     case SVt_PVIV:
 941         SvANY(sv) = new_XPVIV();
 942         SvPVX(sv)       = pv;
 943         SvCUR(sv)       = cur;
 944         SvLEN(sv)       = len;
 945         SvIVX(sv)       = iv;
 946         if (SvNIOK(sv))
 947             (void)SvIOK_on(sv);
 948         SvNOK_off(sv);
 949         break;
 950     case SVt_PVNV:
 951         SvANY(sv) = new_XPVNV();
 952         SvPVX(sv)       = pv;
 953         SvCUR(sv)       = cur;
 954         SvLEN(sv)       = len;
 955         SvIVX(sv)       = iv;
 956         SvNVX(sv)       = nv;
 957         break;
 958     case SVt_PVMG:
 959         SvANY(sv) = new_XPVMG();
 960         SvPVX(sv)       = pv;
 961         SvCUR(sv)       = cur;
 962         SvLEN(sv)       = len;
 963         SvIVX(sv)       = iv;
 964         SvNVX(sv)       = nv;
 965         SvMAGIC(sv)     = magic;
 966         SvSTASH(sv)     = stash;
 967         break;
 968     case SVt_PVLV:
 969         SvANY(sv) = new_XPVLV();
 970         SvPVX(sv)       = pv;
 971         SvCUR(sv)       = cur;
 972         SvLEN(sv)       = len;
 973         SvIVX(sv)       = iv;
 974         SvNVX(sv)       = nv;
 975         SvMAGIC(sv)     = magic;
 976         SvSTASH(sv)     = stash;
 977         LvTARGOFF(sv)   = 0;
 978         LvTARGLEN(sv)   = 0;
 979         LvTARG(sv)      = 0;
 980         LvTYPE(sv)      = 0;
 981         break;
 982     case SVt_PVAV:
 983         SvANY(sv) = new_XPVAV();
 984         if (pv)
 985             Safefree(pv);
 986         SvPVX(sv)       = 0;
 987         AvMAX(sv)       = -1;
 988         AvFILLp(sv)     = -1;
 989         SvIVX(sv)       = 0;
 990         SvNVX(sv)       = 0.0;
 991         SvMAGIC(sv)     = magic;
 992         SvSTASH(sv)     = stash;
 993         AvALLOC(sv)     = 0;
 994         AvARYLEN(sv)    = 0;
 995         AvFLAGS(sv)     = 0;
 996         break;
 997     case SVt_PVHV:
 998         SvANY(sv) = new_XPVHV();
 999         if (pv)
1000             Safefree(pv);
1001         SvPVX(sv)       = 0;
1002         HvFILL(sv)      = 0;
1003         HvMAX(sv)       = 0;
1004         HvKEYS(sv)      = 0;
1005         SvNVX(sv)       = 0.0;
1006         SvMAGIC(sv)     = magic;
1007         SvSTASH(sv)     = stash;
1008         HvRITER(sv)     = 0;
1009         HvEITER(sv)     = 0;
1010         HvPMROOT(sv)    = 0;
1011         HvNAME(sv)      = 0;
1012         break;
1013     case SVt_PVCV:
1014         SvANY(sv) = new_XPVCV();
1015         Zero(SvANY(sv), 1, XPVCV);
1016         SvPVX(sv)       = pv;
1017         SvCUR(sv)       = cur;
1018         SvLEN(sv)       = len;
1019         SvIVX(sv)       = iv;
1020         SvNVX(sv)       = nv;
1021         SvMAGIC(sv)     = magic;
1022         SvSTASH(sv)     = stash;
1023         break;
1024     case SVt_PVGV:
1025         SvANY(sv) = new_XPVGV();
1026         SvPVX(sv)       = pv;
1027         SvCUR(sv)       = cur;
1028         SvLEN(sv)       = len;
1029         SvIVX(sv)       = iv;
1030         SvNVX(sv)       = nv;
1031         SvMAGIC(sv)     = magic;
1032         SvSTASH(sv)     = stash;
1033         GvGP(sv)        = 0;
1034         GvNAME(sv)      = 0;
1035         GvNAMELEN(sv)   = 0;
1036         GvSTASH(sv)     = 0;
1037         GvFLAGS(sv)     = 0;
1038         break;
1039     case SVt_PVBM:
1040         SvANY(sv) = new_XPVBM();
1041         SvPVX(sv)       = pv;
1042         SvCUR(sv)       = cur;
1043         SvLEN(sv)       = len;
1044         SvIVX(sv)       = iv;
1045         SvNVX(sv)       = nv;
1046         SvMAGIC(sv)     = magic;
1047         SvSTASH(sv)     = stash;
1048         BmRARE(sv)      = 0;
1049         BmUSEFUL(sv)    = 0;
1050         BmPREVIOUS(sv)  = 0;
1051         break;
1052     case SVt_PVFM:
1053         SvANY(sv) = new_XPVFM();
1054         Zero(SvANY(sv), 1, XPVFM);
1055         SvPVX(sv)       = pv;
1056         SvCUR(sv)       = cur;
1057         SvLEN(sv)       = len;
1058         SvIVX(sv)       = iv;
1059         SvNVX(sv)       = nv;
1060         SvMAGIC(sv)     = magic;
1061         SvSTASH(sv)     = stash;
1062         break;
1063     case SVt_PVIO:
1064         SvANY(sv) = new_XPVIO();
1065         Zero(SvANY(sv), 1, XPVIO);
1066         SvPVX(sv)       = pv;
1067         SvCUR(sv)       = cur;
1068         SvLEN(sv)       = len;
1069         SvIVX(sv)       = iv;
1070         SvNVX(sv)       = nv;
1071         SvMAGIC(sv)     = magic;
1072         SvSTASH(sv)     = stash;
1073         IoPAGE_LEN(sv)  = 60;
1074         break;
1075     }
1076     SvFLAGS(sv) &= ~SVTYPEMASK;
1077     SvFLAGS(sv) |= mt;
1078     return TRUE;
1079 }
1080
1081 int
1082 Perl_sv_backoff(pTHX_ register SV *sv)
1083 {
1084     assert(SvOOK(sv));
1085     if (SvIVX(sv)) {
1086         char *s = SvPVX(sv);
1087         SvLEN(sv) += SvIVX(sv);
1088         SvPVX(sv) -= SvIVX(sv);
1089         SvIV_set(sv, 0);
1090         Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1091     }
1092     SvFLAGS(sv) &= ~SVf_OOK;
1093     return 0;
1094 }
1095
1096 /*
1097 =for apidoc sv_grow
1098
1099 Expands the character buffer in the SV.  This will use C<sv_unref> and will
1100 upgrade the SV to C<SVt_PV>.  Returns a pointer to the character buffer.
1101 Use C<SvGROW>.
1102
1103 =cut
1104 */
1105
1106 char *
1107 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1108 {
1109     register char *s;
1110
1111 #ifdef HAS_64K_LIMIT
1112     if (newlen >= 0x10000) {
1113         PerlIO_printf(Perl_debug_log,
1114                       "Allocation too large: %"UVxf"\n", (UV)newlen);
1115         my_exit(1);
1116     }
1117 #endif /* HAS_64K_LIMIT */
1118     if (SvROK(sv))
1119         sv_unref(sv);
1120     if (SvTYPE(sv) < SVt_PV) {
1121         sv_upgrade(sv, SVt_PV);
1122         s = SvPVX(sv);
1123     }
1124     else if (SvOOK(sv)) {       /* pv is offset? */
1125         sv_backoff(sv);
1126         s = SvPVX(sv);
1127         if (newlen > SvLEN(sv))
1128             newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1129 #ifdef HAS_64K_LIMIT
1130         if (newlen >= 0x10000)
1131             newlen = 0xFFFF;
1132 #endif
1133     }
1134     else
1135         s = SvPVX(sv);
1136     if (newlen > SvLEN(sv)) {           /* need more room? */
1137         if (SvLEN(sv) && s) {
1138 #if defined(MYMALLOC) && !defined(LEAKTEST)
1139             STRLEN l = malloced_size((void*)SvPVX(sv));
1140             if (newlen <= l) {
1141                 SvLEN_set(sv, l);
1142                 return s;
1143             } else
1144 #endif
1145             Renew(s,newlen,char);
1146         }
1147         else
1148             New(703,s,newlen,char);
1149         SvPV_set(sv, s);
1150         SvLEN_set(sv, newlen);
1151     }
1152     return s;
1153 }
1154
1155 /*
1156 =for apidoc sv_setiv
1157
1158 Copies an integer into the given SV.  Does not handle 'set' magic.  See
1159 C<sv_setiv_mg>.
1160
1161 =cut
1162 */
1163
1164 void
1165 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1166 {
1167     SV_CHECK_THINKFIRST(sv);
1168     switch (SvTYPE(sv)) {
1169     case SVt_NULL:
1170         sv_upgrade(sv, SVt_IV);
1171         break;
1172     case SVt_NV:
1173         sv_upgrade(sv, SVt_PVNV);
1174         break;
1175     case SVt_RV:
1176     case SVt_PV:
1177         sv_upgrade(sv, SVt_PVIV);
1178         break;
1179
1180     case SVt_PVGV:
1181     case SVt_PVAV:
1182     case SVt_PVHV:
1183     case SVt_PVCV:
1184     case SVt_PVFM:
1185     case SVt_PVIO:
1186         {
1187             dTHR;
1188             Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1189                   PL_op_desc[PL_op->op_type]);
1190         }
1191     }
1192     (void)SvIOK_only(sv);                       /* validate number */
1193     SvIVX(sv) = i;
1194     SvTAINT(sv);
1195 }
1196
1197 /*
1198 =for apidoc sv_setiv_mg
1199
1200 Like C<sv_setiv>, but also handles 'set' magic.
1201
1202 =cut
1203 */
1204
1205 void
1206 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1207 {
1208     sv_setiv(sv,i);
1209     SvSETMAGIC(sv);
1210 }
1211
1212 /*
1213 =for apidoc sv_setuv
1214
1215 Copies an unsigned integer into the given SV.  Does not handle 'set' magic.
1216 See C<sv_setuv_mg>.
1217
1218 =cut
1219 */
1220
1221 void
1222 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1223 {
1224     sv_setiv(sv, 0);
1225     SvIsUV_on(sv);
1226     SvUVX(sv) = u;
1227 }
1228
1229 /*
1230 =for apidoc sv_setuv_mg
1231
1232 Like C<sv_setuv>, but also handles 'set' magic.
1233
1234 =cut
1235 */
1236
1237 void
1238 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1239 {
1240     sv_setuv(sv,u);
1241     SvSETMAGIC(sv);
1242 }
1243
1244 /*
1245 =for apidoc sv_setnv
1246
1247 Copies a double into the given SV.  Does not handle 'set' magic.  See
1248 C<sv_setnv_mg>.
1249
1250 =cut
1251 */
1252
1253 void
1254 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1255 {
1256     SV_CHECK_THINKFIRST(sv);
1257     switch (SvTYPE(sv)) {
1258     case SVt_NULL:
1259     case SVt_IV:
1260         sv_upgrade(sv, SVt_NV);
1261         break;
1262     case SVt_RV:
1263     case SVt_PV:
1264     case SVt_PVIV:
1265         sv_upgrade(sv, SVt_PVNV);
1266         break;
1267
1268     case SVt_PVGV:
1269     case SVt_PVAV:
1270     case SVt_PVHV:
1271     case SVt_PVCV:
1272     case SVt_PVFM:
1273     case SVt_PVIO:
1274         {
1275             dTHR;
1276             Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1277                   PL_op_name[PL_op->op_type]);
1278         }
1279     }
1280     SvNVX(sv) = num;
1281     (void)SvNOK_only(sv);                       /* validate number */
1282     SvTAINT(sv);
1283 }
1284
1285 /*
1286 =for apidoc sv_setnv_mg
1287
1288 Like C<sv_setnv>, but also handles 'set' magic.
1289
1290 =cut
1291 */
1292
1293 void
1294 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1295 {
1296     sv_setnv(sv,num);
1297     SvSETMAGIC(sv);
1298 }
1299
1300 STATIC void
1301 S_not_a_number(pTHX_ SV *sv)
1302 {
1303     dTHR;
1304     char tmpbuf[64];
1305     char *d = tmpbuf;
1306     char *s;
1307     char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1308                   /* each *s can expand to 4 chars + "...\0",
1309                      i.e. need room for 8 chars */
1310
1311     for (s = SvPVX(sv); *s && d < limit; s++) {
1312         int ch = *s & 0xFF;
1313         if (ch & 128 && !isPRINT_LC(ch)) {
1314             *d++ = 'M';
1315             *d++ = '-';
1316             ch &= 127;
1317         }
1318         if (ch == '\n') {
1319             *d++ = '\\';
1320             *d++ = 'n';
1321         }
1322         else if (ch == '\r') {
1323             *d++ = '\\';
1324             *d++ = 'r';
1325         }
1326         else if (ch == '\f') {
1327             *d++ = '\\';
1328             *d++ = 'f';
1329         }
1330         else if (ch == '\\') {
1331             *d++ = '\\';
1332             *d++ = '\\';
1333         }
1334         else if (isPRINT_LC(ch))
1335             *d++ = ch;
1336         else {
1337             *d++ = '^';
1338             *d++ = toCTRL(ch);
1339         }
1340     }
1341     if (*s) {
1342         *d++ = '.';
1343         *d++ = '.';
1344         *d++ = '.';
1345     }
1346     *d = '\0';
1347
1348     if (PL_op)
1349         Perl_warner(aTHX_ WARN_NUMERIC,
1350                     "Argument \"%s\" isn't numeric in %s", tmpbuf,
1351                 PL_op_desc[PL_op->op_type]);
1352     else
1353         Perl_warner(aTHX_ WARN_NUMERIC,
1354                     "Argument \"%s\" isn't numeric", tmpbuf);
1355 }
1356
1357 /* the number can be converted to integer with atol() or atoll() */
1358 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1359 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1360 #define IS_NUMBER_NOT_IV         0x04 /* (IV)atof() may be != atof() */
1361 #define IS_NUMBER_NEG            0x08 /* not good to cache UV */
1362
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((U8*)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                         Perl_croak(aTHX_ "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((U8*)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 ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
2666                                     Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2667                                              "Constant subroutine %s redefined"
2668                                              : "Subroutine %s redefined",
2669                                              GvENAME((GV*)dstr));
2670                             }
2671                             cv_ckproto(cv, (GV*)dstr,
2672                                        SvPOK(sref) ? SvPVX(sref) : Nullch);
2673                         }
2674                         GvCV(dstr) = (CV*)sref;
2675                         GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2676                         GvASSUMECV_on(dstr);
2677                         PL_sub_generation++;
2678                     }
2679                     if (GvIMPORTED_CV_off(dstr)
2680                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2681                     {
2682                         GvIMPORTED_CV_on(dstr);
2683                     }
2684                     break;
2685                 case SVt_PVIO:
2686                     if (intro)
2687                         SAVESPTR(GvIOp(dstr));
2688                     else
2689                         dref = (SV*)GvIOp(dstr);
2690                     GvIOp(dstr) = (IO*)sref;
2691                     break;
2692                 default:
2693                     if (intro)
2694                         SAVESPTR(GvSV(dstr));
2695                     else
2696                         dref = (SV*)GvSV(dstr);
2697                     GvSV(dstr) = sref;
2698                     if (GvIMPORTED_SV_off(dstr)
2699                         && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2700                     {
2701                         GvIMPORTED_SV_on(dstr);
2702                     }
2703                     break;
2704                 }
2705                 if (dref)
2706                     SvREFCNT_dec(dref);
2707                 if (intro)
2708                     SAVEFREESV(sref);
2709                 SvTAINT(dstr);
2710                 return;
2711             }
2712             if (SvPVX(dstr)) {
2713                 (void)SvOOK_off(dstr);          /* backoff */
2714                 if (SvLEN(dstr))
2715                     Safefree(SvPVX(dstr));
2716                 SvLEN(dstr)=SvCUR(dstr)=0;
2717             }
2718         }
2719         (void)SvOK_off(dstr);
2720         SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2721         SvROK_on(dstr);
2722         if (sflags & SVp_NOK) {
2723             SvNOK_on(dstr);
2724             SvNVX(dstr) = SvNVX(sstr);
2725         }
2726         if (sflags & SVp_IOK) {
2727             (void)SvIOK_on(dstr);
2728             SvIVX(dstr) = SvIVX(sstr);
2729             if (SvIsUV(sstr))
2730                 SvIsUV_on(dstr);
2731         }
2732         if (SvAMAGIC(sstr)) {
2733             SvAMAGIC_on(dstr);
2734         }
2735     }
2736     else if (sflags & SVp_POK) {
2737
2738         /*
2739          * Check to see if we can just swipe the string.  If so, it's a
2740          * possible small lose on short strings, but a big win on long ones.
2741          * It might even be a win on short strings if SvPVX(dstr)
2742          * has to be allocated and SvPVX(sstr) has to be freed.
2743          */
2744
2745         if (SvTEMP(sstr) &&             /* slated for free anyway? */
2746             SvREFCNT(sstr) == 1 &&      /* and no other references to it? */
2747             !(sflags & SVf_OOK))        /* and not involved in OOK hack? */
2748         {
2749             if (SvPVX(dstr)) {          /* we know that dtype >= SVt_PV */
2750                 if (SvOOK(dstr)) {
2751                     SvFLAGS(dstr) &= ~SVf_OOK;
2752                     Safefree(SvPVX(dstr) - SvIVX(dstr));
2753                 }
2754                 else if (SvLEN(dstr))
2755                     Safefree(SvPVX(dstr));
2756             }
2757             (void)SvPOK_only(dstr);
2758             SvPV_set(dstr, SvPVX(sstr));
2759             SvLEN_set(dstr, SvLEN(sstr));
2760             SvCUR_set(dstr, SvCUR(sstr));
2761             if (SvUTF8(sstr))
2762                 SvUTF8_on(dstr);
2763             else
2764                 SvUTF8_off(dstr);
2765
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_MISC))
2816                 Perl_warner(aTHX_ WARN_MISC, "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         bool vectorize = FALSE;
5738         bool utf = FALSE;
5739         char fill = ' ';
5740         char plus = 0;
5741         char intsize = 0;
5742         STRLEN width = 0;
5743         STRLEN zeros = 0;
5744         bool has_precis = FALSE;
5745         STRLEN precis = 0;
5746         bool is_utf = FALSE;
5747
5748         char esignbuf[4];
5749         U8 utf8buf[UTF8_MAXLEN];
5750         STRLEN esignlen = 0;
5751
5752         char *eptr = Nullch;
5753         STRLEN elen = 0;
5754         /* Times 4: a decimal digit takes more than 3 binary digits.
5755          * NV_DIG: mantissa takes than many decimal digits.
5756          * Plus 32: Playing safe. */
5757         char ebuf[IV_DIG * 4 + NV_DIG + 32];
5758         /* large enough for "%#.#f" --chip */
5759         /* what about long double NVs? --jhi */
5760
5761         SV *vecsv;
5762         U8 *vecstr = Null(U8*);
5763         STRLEN veclen = 0;
5764         char c;
5765         int i;
5766         unsigned base;
5767         IV iv;
5768         UV uv;
5769         NV nv;
5770         STRLEN have;
5771         STRLEN need;
5772         STRLEN gap;
5773         char *dotstr = ".";
5774         STRLEN dotstrlen = 1;
5775
5776         for (q = p; q < patend && *q != '%'; ++q) ;
5777         if (q > p) {
5778             sv_catpvn(sv, p, q - p);
5779             p = q;
5780         }
5781         if (q++ >= patend)
5782             break;
5783
5784         /* FLAGS */
5785
5786         while (*q) {
5787             switch (*q) {
5788             case ' ':
5789             case '+':
5790                 plus = *q++;
5791                 continue;
5792
5793             case '-':
5794                 left = TRUE;
5795                 q++;
5796                 continue;
5797
5798             case '0':
5799                 fill = *q++;
5800                 continue;
5801
5802             case '#':
5803                 alt = TRUE;
5804                 q++;
5805                 continue;
5806
5807             case '*':                   /* printf("%*vX",":",$ipv6addr) */
5808                 if (q[1] != 'v')
5809                     break;
5810                 q++;
5811                 if (args)
5812                     vecsv = va_arg(*args, SV*);
5813                 else if (svix < svmax)
5814                     vecsv = svargs[svix++];
5815                 dotstr = SvPVx(vecsv,dotstrlen);
5816                 if (DO_UTF8(vecsv))
5817                     is_utf = TRUE;
5818                 /* FALL THROUGH */
5819
5820             case 'v':
5821                 vectorize = TRUE;
5822                 q++;
5823                 if (args)
5824                     vecsv = va_arg(*args, SV*);
5825                 else if (svix < svmax)
5826                     vecsv = svargs[svix++];
5827                 vecstr = (U8*)SvPVx(vecsv,veclen);
5828                 utf = DO_UTF8(vecsv);
5829                 continue;
5830
5831             default:
5832                 break;
5833             }
5834             break;
5835         }
5836
5837         /* WIDTH */
5838
5839         switch (*q) {
5840         case '1': case '2': case '3':
5841         case '4': case '5': case '6':
5842         case '7': case '8': case '9':
5843             width = 0;
5844             while (isDIGIT(*q))
5845                 width = width * 10 + (*q++ - '0');
5846             break;
5847
5848         case '*':
5849             if (args)
5850                 i = va_arg(*args, int);
5851             else
5852                 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5853             left |= (i < 0);
5854             width = (i < 0) ? -i : i;
5855             q++;
5856             break;
5857         }
5858
5859         /* PRECISION */
5860
5861         if (*q == '.') {
5862             q++;
5863             if (*q == '*') {
5864                 if (args)
5865                     i = va_arg(*args, int);
5866                 else
5867                     i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5868                 precis = (i < 0) ? 0 : i;
5869                 q++;
5870             }
5871             else {
5872                 precis = 0;
5873                 while (isDIGIT(*q))
5874                     precis = precis * 10 + (*q++ - '0');
5875             }
5876             has_precis = TRUE;
5877         }
5878
5879         /* SIZE */
5880
5881         switch (*q) {
5882 #ifdef HAS_QUAD
5883         case 'L':                       /* Ld */
5884         case 'q':                       /* qd */
5885             intsize = 'q';
5886             q++;
5887             break;
5888 #endif
5889         case 'l':
5890 #ifdef HAS_QUAD
5891              if (*(q + 1) == 'l') {     /* lld */
5892                 intsize = 'q';
5893                 q += 2;
5894                 break;
5895              }
5896 #endif
5897             /* FALL THROUGH */
5898         case 'h':
5899             /* FALL THROUGH */
5900         case 'V':
5901             intsize = *q++;
5902             break;
5903         }
5904
5905         /* CONVERSION */
5906
5907         switch (c = *q++) {
5908
5909             /* STRINGS */
5910
5911         case '%':
5912             eptr = q - 1;
5913             elen = 1;
5914             goto string;
5915
5916         case 'c':
5917             if (args)
5918                 uv = va_arg(*args, int);
5919             else
5920                 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5921             if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
5922                 eptr = (char*)utf8buf;
5923                 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5924                 is_utf = TRUE;
5925             }
5926             else {
5927                 c = (char)uv;
5928                 eptr = &c;
5929                 elen = 1;
5930             }
5931             goto string;
5932
5933         case 's':
5934             if (args) {
5935                 eptr = va_arg(*args, char*);
5936                 if (eptr)
5937 #ifdef MACOS_TRADITIONAL
5938                   /* On MacOS, %#s format is used for Pascal strings */
5939                   if (alt)
5940                     elen = *eptr++;
5941                   else
5942 #endif
5943                     elen = strlen(eptr);
5944                 else {
5945                     eptr = nullstr;
5946                     elen = sizeof nullstr - 1;
5947                 }
5948             }
5949             else if (svix < svmax) {
5950                 argsv = svargs[svix++];
5951                 eptr = SvPVx(argsv, elen);
5952                 if (DO_UTF8(argsv)) {
5953                     if (has_precis && precis < elen) {
5954                         I32 p = precis;
5955                         sv_pos_u2b(argsv, &p, 0); /* sticks at end */
5956                         precis = p;
5957                     }
5958                     if (width) { /* fudge width (can't fudge elen) */
5959                         width += elen - sv_len_utf8(argsv);
5960                     }
5961                     is_utf = TRUE;
5962                 }
5963             }
5964             goto string;
5965
5966         case '_':
5967             /*
5968              * The "%_" hack might have to be changed someday,
5969              * if ISO or ANSI decide to use '_' for something.
5970              * So we keep it hidden from users' code.
5971              */
5972             if (!args)
5973                 goto unknown;
5974             argsv = va_arg(*args,SV*);
5975             eptr = SvPVx(argsv, elen);
5976             if (DO_UTF8(argsv))
5977                 is_utf = TRUE;
5978
5979         string:
5980             vectorize = FALSE;
5981             if (has_precis && elen > precis)
5982                 elen = precis;
5983             break;
5984
5985             /* INTEGERS */
5986
5987         case 'p':
5988             if (args)
5989                 uv = PTR2UV(va_arg(*args, void*));
5990             else
5991                 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5992             base = 16;
5993             goto integer;
5994
5995         case 'D':
5996 #ifdef IV_IS_QUAD
5997             intsize = 'q';
5998 #else
5999             intsize = 'l';
6000 #endif
6001             /* FALL THROUGH */
6002         case 'd':
6003         case 'i':
6004             if (vectorize) {
6005                 I32 ulen;
6006                 if (!veclen) {
6007                     vectorize = FALSE;
6008                     break;
6009                 }
6010                 if (utf)
6011                     iv = (IV)utf8_to_uv(vecstr, &ulen);
6012                 else {
6013                     iv = *vecstr;
6014                     ulen = 1;
6015                 }
6016                 vecstr += ulen;
6017                 veclen -= ulen;
6018             }
6019             else if (args) {
6020                 switch (intsize) {
6021                 case 'h':       iv = (short)va_arg(*args, int); break;
6022                 default:        iv = va_arg(*args, int); break;
6023                 case 'l':       iv = va_arg(*args, long); break;
6024                 case 'V':       iv = va_arg(*args, IV); break;
6025 #ifdef HAS_QUAD
6026                 case 'q':       iv = va_arg(*args, Quad_t); break;
6027 #endif
6028                 }
6029             }
6030             else {
6031                 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6032                 switch (intsize) {
6033                 case 'h':       iv = (short)iv; break;
6034                 default:        iv = (int)iv; break;
6035                 case 'l':       iv = (long)iv; break;
6036                 case 'V':       break;
6037 #ifdef HAS_QUAD
6038                 case 'q':       iv = (Quad_t)iv; break;
6039 #endif
6040                 }
6041             }
6042             if (iv >= 0) {
6043                 uv = iv;
6044                 if (plus)
6045                     esignbuf[esignlen++] = plus;
6046             }
6047             else {
6048                 uv = -iv;
6049                 esignbuf[esignlen++] = '-';
6050             }
6051             base = 10;
6052             goto integer;
6053
6054         case 'U':
6055 #ifdef IV_IS_QUAD
6056             intsize = 'q';
6057 #else
6058             intsize = 'l';
6059 #endif
6060             /* FALL THROUGH */
6061         case 'u':
6062             base = 10;
6063             goto uns_integer;
6064
6065         case 'b':
6066             base = 2;
6067             goto uns_integer;
6068
6069         case 'O':
6070 #ifdef IV_IS_QUAD
6071             intsize = 'q';
6072 #else
6073             intsize = 'l';
6074 #endif
6075             /* FALL THROUGH */
6076         case 'o':
6077             base = 8;
6078             goto uns_integer;
6079
6080         case 'X':
6081         case 'x':
6082             base = 16;
6083
6084         uns_integer:
6085             if (vectorize) {
6086                 I32 ulen;
6087         vector:
6088                 if (!veclen) {
6089                     vectorize = FALSE;
6090                     break;
6091                 }
6092                 if (utf)
6093                     uv = utf8_to_uv(vecstr, &ulen);
6094                 else {
6095                     uv = *vecstr;
6096                     ulen = 1;
6097                 }
6098                 vecstr += ulen;
6099                 veclen -= ulen;
6100             }
6101             else if (args) {
6102                 switch (intsize) {
6103                 case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
6104                 default:   uv = va_arg(*args, unsigned); break;
6105                 case 'l':  uv = va_arg(*args, unsigned long); break;
6106                 case 'V':  uv = va_arg(*args, UV); break;
6107 #ifdef HAS_QUAD
6108                 case 'q':  uv = va_arg(*args, Quad_t); break;
6109 #endif
6110                 }
6111             }
6112             else {
6113                 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6114                 switch (intsize) {
6115                 case 'h':       uv = (unsigned short)uv; break;
6116                 default:        uv = (unsigned)uv; break;
6117                 case 'l':       uv = (unsigned long)uv; break;
6118                 case 'V':       break;
6119 #ifdef HAS_QUAD
6120                 case 'q':       uv = (Quad_t)uv; break;
6121 #endif
6122                 }
6123             }
6124
6125         integer:
6126             eptr = ebuf + sizeof ebuf;
6127             switch (base) {
6128                 unsigned dig;
6129             case 16:
6130                 if (!uv)
6131                     alt = FALSE;
6132                 p = (char*)((c == 'X')
6133                             ? "0123456789ABCDEF" : "0123456789abcdef");
6134                 do {
6135                     dig = uv & 15;
6136                     *--eptr = p[dig];
6137                 } while (uv >>= 4);
6138                 if (alt) {
6139                     esignbuf[esignlen++] = '0';
6140                     esignbuf[esignlen++] = c;  /* 'x' or 'X' */
6141                 }
6142                 break;
6143             case 8:
6144                 do {
6145                     dig = uv & 7;
6146                     *--eptr = '0' + dig;
6147                 } while (uv >>= 3);
6148                 if (alt && *eptr != '0')
6149                     *--eptr = '0';
6150                 break;
6151             case 2:
6152                 do {
6153                     dig = uv & 1;
6154                     *--eptr = '0' + dig;
6155                 } while (uv >>= 1);
6156                 if (alt) {
6157                     esignbuf[esignlen++] = '0';
6158                     esignbuf[esignlen++] = 'b';
6159                 }
6160                 break;
6161             default:            /* it had better be ten or less */
6162 #if defined(PERL_Y2KWARN)
6163                 if (ckWARN(WARN_Y2K)) {
6164                     STRLEN n;
6165                     char *s = SvPV(sv,n);
6166                     if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6167                         && (n == 2 || !isDIGIT(s[n-3])))
6168                     {
6169                         Perl_warner(aTHX_ WARN_Y2K,
6170                                     "Possible Y2K bug: %%%c %s",
6171                                     c, "format string following '19'");
6172                     }
6173                 }
6174 #endif
6175                 do {
6176                     dig = uv % base;
6177                     *--eptr = '0' + dig;
6178                 } while (uv /= base);
6179                 break;
6180             }
6181             elen = (ebuf + sizeof ebuf) - eptr;
6182             if (has_precis) {
6183                 if (precis > elen)
6184                     zeros = precis - elen;
6185                 else if (precis == 0 && elen == 1 && *eptr == '0')
6186                     elen = 0;
6187             }
6188             break;
6189
6190             /* FLOATING POINT */
6191
6192         case 'F':
6193             c = 'f';            /* maybe %F isn't supported here */
6194             /* FALL THROUGH */
6195         case 'e': case 'E':
6196         case 'f':
6197         case 'g': case 'G':
6198
6199             /* This is evil, but floating point is even more evil */
6200
6201             vectorize = FALSE;
6202             if (args)
6203                 nv = va_arg(*args, NV);
6204             else
6205                 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6206
6207             need = 0;
6208             if (c != 'e' && c != 'E') {
6209                 i = PERL_INT_MIN;
6210                 (void)frexp(nv, &i);
6211                 if (i == PERL_INT_MIN)
6212                     Perl_die(aTHX_ "panic: frexp");
6213                 if (i > 0)
6214                     need = BIT_DIGITS(i);
6215             }
6216             need += has_precis ? precis : 6; /* known default */
6217             if (need < width)
6218                 need = width;
6219
6220             need += 20; /* fudge factor */
6221             if (PL_efloatsize < need) {
6222                 Safefree(PL_efloatbuf);
6223                 PL_efloatsize = need + 20; /* more fudge */
6224                 New(906, PL_efloatbuf, PL_efloatsize, char);
6225                 PL_efloatbuf[0] = '\0';
6226             }
6227
6228             eptr = ebuf + sizeof ebuf;
6229             *--eptr = '\0';
6230             *--eptr = c;
6231 #ifdef USE_LONG_DOUBLE
6232             {
6233                 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
6234                 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
6235             }
6236 #endif
6237             if (has_precis) {
6238                 base = precis;
6239                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6240                 *--eptr = '.';
6241             }
6242             if (width) {
6243                 base = width;
6244                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6245             }
6246             if (fill == '0')
6247                 *--eptr = fill;
6248             if (left)
6249                 *--eptr = '-';
6250             if (plus)
6251                 *--eptr = plus;
6252             if (alt)
6253                 *--eptr = '#';
6254             *--eptr = '%';
6255
6256             {
6257                 RESTORE_NUMERIC_STANDARD();
6258                 (void)sprintf(PL_efloatbuf, eptr, nv);
6259                 RESTORE_NUMERIC_LOCAL();
6260             }
6261
6262             eptr = PL_efloatbuf;
6263             elen = strlen(PL_efloatbuf);
6264             break;
6265
6266             /* SPECIAL */
6267
6268         case 'n':
6269             vectorize = FALSE;
6270             i = SvCUR(sv) - origlen;
6271             if (args) {
6272                 switch (intsize) {
6273                 case 'h':       *(va_arg(*args, short*)) = i; break;
6274                 default:        *(va_arg(*args, int*)) = i; break;
6275                 case 'l':       *(va_arg(*args, long*)) = i; break;
6276                 case 'V':       *(va_arg(*args, IV*)) = i; break;
6277 #ifdef HAS_QUAD
6278                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
6279 #endif
6280                 }
6281             }
6282             else if (svix < svmax)
6283                 sv_setuv(svargs[svix++], (UV)i);
6284             continue;   /* not "break" */
6285
6286             /* UNKNOWN */
6287
6288         default:
6289       unknown:
6290             vectorize = FALSE;
6291             if (!args && ckWARN(WARN_PRINTF) &&
6292                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6293                 SV *msg = sv_newmortal();
6294                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6295                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6296                 if (c) {
6297                     if (isPRINT(c))
6298                         Perl_sv_catpvf(aTHX_ msg,
6299                                        "\"%%%c\"", c & 0xFF);
6300                     else
6301                         Perl_sv_catpvf(aTHX_ msg,
6302                                        "\"%%\\%03"UVof"\"",
6303                                        (UV)c & 0xFF);
6304                 } else
6305                     sv_catpv(msg, "end of string");
6306                 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6307             }
6308
6309             /* output mangled stuff ... */
6310             if (c == '\0')
6311                 --q;
6312             eptr = p;
6313             elen = q - p;
6314
6315             /* ... right here, because formatting flags should not apply */
6316             SvGROW(sv, SvCUR(sv) + elen + 1);
6317             p = SvEND(sv);
6318             memcpy(p, eptr, elen);
6319             p += elen;
6320             *p = '\0';
6321             SvCUR(sv) = p - SvPVX(sv);
6322             continue;   /* not "break" */
6323         }
6324
6325         have = esignlen + zeros + elen;
6326         need = (have > width ? have : width);
6327         gap = need - have;
6328
6329         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6330         p = SvEND(sv);
6331         if (esignlen && fill == '0') {
6332             for (i = 0; i < esignlen; i++)
6333                 *p++ = esignbuf[i];
6334         }
6335         if (gap && !left) {
6336             memset(p, fill, gap);
6337             p += gap;
6338         }
6339         if (esignlen && fill != '0') {
6340             for (i = 0; i < esignlen; i++)
6341                 *p++ = esignbuf[i];
6342         }
6343         if (zeros) {
6344             for (i = zeros; i; i--)
6345                 *p++ = '0';
6346         }
6347         if (elen) {
6348             memcpy(p, eptr, elen);
6349             p += elen;
6350         }
6351         if (gap && left) {
6352             memset(p, ' ', gap);
6353             p += gap;
6354         }
6355         if (vectorize) {
6356             if (veclen) {
6357                 memcpy(p, dotstr, dotstrlen);
6358                 p += dotstrlen;
6359             }
6360             else
6361                 vectorize = FALSE;              /* done iterating over vecstr */
6362         }
6363         if (is_utf)
6364             SvUTF8_on(sv);
6365         *p = '\0';
6366         SvCUR(sv) = p - SvPVX(sv);
6367         if (vectorize) {
6368             esignlen = 0;
6369             goto vector;
6370         }
6371     }
6372 }
6373
6374 #if defined(USE_ITHREADS)
6375
6376 #if defined(USE_THREADS)
6377 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
6378 #endif
6379
6380 #ifndef OpREFCNT_inc
6381 #  define OpREFCNT_inc(o)       ((o) ? (++(o)->op_targ, (o)) : Nullop)
6382 #endif
6383
6384 #ifndef GpREFCNT_inc
6385 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6386 #endif
6387
6388
6389 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
6390 #define av_dup(s)       (AV*)sv_dup((SV*)s)
6391 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6392 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
6393 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6394 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
6395 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6396 #define io_dup(s)       (IO*)sv_dup((SV*)s)
6397 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6398 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
6399 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6400 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
6401 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
6402
6403 REGEXP *
6404 Perl_re_dup(pTHX_ REGEXP *r)
6405 {
6406     /* XXX fix when pmop->op_pmregexp becomes shared */
6407     return ReREFCNT_inc(r);
6408 }
6409
6410 PerlIO *
6411 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6412 {
6413     PerlIO *ret;
6414     if (!fp)
6415         return (PerlIO*)NULL;
6416
6417     /* look for it in the table first */
6418     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6419     if (ret)
6420         return ret;
6421
6422     /* create anew and remember what it is */
6423     ret = PerlIO_fdupopen(fp);
6424     ptr_table_store(PL_ptr_table, fp, ret);
6425     return ret;
6426 }
6427
6428 DIR *
6429 Perl_dirp_dup(pTHX_ DIR *dp)
6430 {
6431     if (!dp)
6432         return (DIR*)NULL;
6433     /* XXX TODO */
6434     return dp;
6435 }
6436
6437 GP *
6438 Perl_gp_dup(pTHX_ GP *gp)
6439 {
6440     GP *ret;
6441     if (!gp)
6442         return (GP*)NULL;
6443     /* look for it in the table first */
6444     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6445     if (ret)
6446         return ret;
6447
6448     /* create anew and remember what it is */
6449     Newz(0, ret, 1, GP);
6450     ptr_table_store(PL_ptr_table, gp, ret);
6451
6452     /* clone */
6453     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
6454     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
6455     ret->gp_io          = io_dup_inc(gp->gp_io);
6456     ret->gp_form        = cv_dup_inc(gp->gp_form);
6457     ret->gp_av          = av_dup_inc(gp->gp_av);
6458     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
6459     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
6460     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
6461     ret->gp_cvgen       = gp->gp_cvgen;
6462     ret->gp_flags       = gp->gp_flags;
6463     ret->gp_line        = gp->gp_line;
6464     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
6465     return ret;
6466 }
6467
6468 MAGIC *
6469 Perl_mg_dup(pTHX_ MAGIC *mg)
6470 {
6471     MAGIC *mgret = (MAGIC*)NULL;
6472     MAGIC *mgprev;
6473     if (!mg)
6474         return (MAGIC*)NULL;
6475     /* look for it in the table first */
6476     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6477     if (mgret)
6478         return mgret;
6479
6480     for (; mg; mg = mg->mg_moremagic) {
6481         MAGIC *nmg;
6482         Newz(0, nmg, 1, MAGIC);
6483         if (!mgret)
6484             mgret = nmg;
6485         else
6486             mgprev->mg_moremagic = nmg;
6487         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
6488         nmg->mg_private = mg->mg_private;
6489         nmg->mg_type    = mg->mg_type;
6490         nmg->mg_flags   = mg->mg_flags;
6491         if (mg->mg_type == 'r') {
6492             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6493         }
6494         else {
6495             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6496                               ? sv_dup_inc(mg->mg_obj)
6497                               : sv_dup(mg->mg_obj);
6498         }
6499         nmg->mg_len     = mg->mg_len;
6500         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
6501         if (mg->mg_ptr && mg->mg_type != 'g') {
6502             if (mg->mg_len >= 0) {
6503                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
6504                 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6505                     AMT *amtp = (AMT*)mg->mg_ptr;
6506                     AMT *namtp = (AMT*)nmg->mg_ptr;
6507                     I32 i;
6508                     for (i = 1; i < NofAMmeth; i++) {
6509                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
6510                     }
6511                 }
6512             }
6513             else if (mg->mg_len == HEf_SVKEY)
6514                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6515         }
6516         mgprev = nmg;
6517     }
6518     return mgret;
6519 }
6520
6521 PTR_TBL_t *
6522 Perl_ptr_table_new(pTHX)
6523 {
6524     PTR_TBL_t *tbl;
6525     Newz(0, tbl, 1, PTR_TBL_t);
6526     tbl->tbl_max        = 511;
6527     tbl->tbl_items      = 0;
6528     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6529     return tbl;
6530 }
6531
6532 void *
6533 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6534 {
6535     PTR_TBL_ENT_t *tblent;
6536     UV hash = PTR2UV(sv);
6537     assert(tbl);
6538     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6539     for (; tblent; tblent = tblent->next) {
6540         if (tblent->oldval == sv)
6541             return tblent->newval;
6542     }
6543     return (void*)NULL;
6544 }
6545
6546 void
6547 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6548 {
6549     PTR_TBL_ENT_t *tblent, **otblent;
6550     /* XXX this may be pessimal on platforms where pointers aren't good
6551      * hash values e.g. if they grow faster in the most significant
6552      * bits */
6553     UV hash = PTR2UV(oldv);
6554     bool i = 1;
6555
6556     assert(tbl);
6557     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6558     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6559         if (tblent->oldval == oldv) {
6560             tblent->newval = newv;
6561             tbl->tbl_items++;
6562             return;
6563         }
6564     }
6565     Newz(0, tblent, 1, PTR_TBL_ENT_t);
6566     tblent->oldval = oldv;
6567     tblent->newval = newv;
6568     tblent->next = *otblent;
6569     *otblent = tblent;
6570     tbl->tbl_items++;
6571     if (i && tbl->tbl_items > tbl->tbl_max)
6572         ptr_table_split(tbl);
6573 }
6574
6575 void
6576 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6577 {
6578     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6579     UV oldsize = tbl->tbl_max + 1;
6580     UV newsize = oldsize * 2;
6581     UV i;
6582
6583     Renew(ary, newsize, PTR_TBL_ENT_t*);
6584     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6585     tbl->tbl_max = --newsize;
6586     tbl->tbl_ary = ary;
6587     for (i=0; i < oldsize; i++, ary++) {
6588         PTR_TBL_ENT_t **curentp, **entp, *ent;
6589         if (!*ary)
6590             continue;
6591         curentp = ary + oldsize;
6592         for (entp = ary, ent = *ary; ent; ent = *entp) {
6593             if ((newsize & PTR2UV(ent->oldval)) != i) {
6594                 *entp = ent->next;
6595                 ent->next = *curentp;
6596                 *curentp = ent;
6597                 continue;
6598             }
6599             else
6600                 entp = &ent->next;
6601         }
6602     }
6603 }
6604
6605 #ifdef DEBUGGING
6606 char *PL_watch_pvx;
6607 #endif
6608
6609 SV *
6610 Perl_sv_dup(pTHX_ SV *sstr)
6611 {
6612     U32 sflags;
6613     int dtype;
6614     int stype;
6615     SV *dstr;
6616
6617     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6618         return Nullsv;
6619     /* look for it in the table first */
6620     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6621     if (dstr)
6622         return dstr;
6623
6624     /* create anew and remember what it is */
6625     new_SV(dstr);
6626     ptr_table_store(PL_ptr_table, sstr, dstr);
6627
6628     /* clone */
6629     SvFLAGS(dstr)       = SvFLAGS(sstr);
6630     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
6631     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
6632
6633 #ifdef DEBUGGING
6634     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6635         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6636                       PL_watch_pvx, SvPVX(sstr));
6637 #endif
6638
6639     switch (SvTYPE(sstr)) {
6640     case SVt_NULL:
6641         SvANY(dstr)     = NULL;
6642         break;
6643     case SVt_IV:
6644         SvANY(dstr)     = new_XIV();
6645         SvIVX(dstr)     = SvIVX(sstr);
6646         break;
6647     case SVt_NV:
6648         SvANY(dstr)     = new_XNV();
6649         SvNVX(dstr)     = SvNVX(sstr);
6650         break;
6651     case SVt_RV:
6652         SvANY(dstr)     = new_XRV();
6653         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
6654         break;
6655     case SVt_PV:
6656         SvANY(dstr)     = new_XPV();
6657         SvCUR(dstr)     = SvCUR(sstr);
6658         SvLEN(dstr)     = SvLEN(sstr);
6659         if (SvROK(sstr))
6660             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6661         else if (SvPVX(sstr) && SvLEN(sstr))
6662             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6663         else
6664             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6665         break;
6666     case SVt_PVIV:
6667         SvANY(dstr)     = new_XPVIV();
6668         SvCUR(dstr)     = SvCUR(sstr);
6669         SvLEN(dstr)     = SvLEN(sstr);
6670         SvIVX(dstr)     = SvIVX(sstr);
6671         if (SvROK(sstr))
6672             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6673         else if (SvPVX(sstr) && SvLEN(sstr))
6674             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6675         else
6676             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6677         break;
6678     case SVt_PVNV:
6679         SvANY(dstr)     = new_XPVNV();
6680         SvCUR(dstr)     = SvCUR(sstr);
6681         SvLEN(dstr)     = SvLEN(sstr);
6682         SvIVX(dstr)     = SvIVX(sstr);
6683         SvNVX(dstr)     = SvNVX(sstr);
6684         if (SvROK(sstr))
6685             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6686         else if (SvPVX(sstr) && SvLEN(sstr))
6687             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6688         else
6689             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6690         break;
6691     case SVt_PVMG:
6692         SvANY(dstr)     = new_XPVMG();
6693         SvCUR(dstr)     = SvCUR(sstr);
6694         SvLEN(dstr)     = SvLEN(sstr);
6695         SvIVX(dstr)     = SvIVX(sstr);
6696         SvNVX(dstr)     = SvNVX(sstr);
6697         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6698         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6699         if (SvROK(sstr))
6700             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6701         else if (SvPVX(sstr) && SvLEN(sstr))
6702             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6703         else
6704             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6705         break;
6706     case SVt_PVBM:
6707         SvANY(dstr)     = new_XPVBM();
6708         SvCUR(dstr)     = SvCUR(sstr);
6709         SvLEN(dstr)     = SvLEN(sstr);
6710         SvIVX(dstr)     = SvIVX(sstr);
6711         SvNVX(dstr)     = SvNVX(sstr);
6712         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6713         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6714         if (SvROK(sstr))
6715             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6716         else if (SvPVX(sstr) && SvLEN(sstr))
6717             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6718         else
6719             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6720         BmRARE(dstr)    = BmRARE(sstr);
6721         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
6722         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6723         break;
6724     case SVt_PVLV:
6725         SvANY(dstr)     = new_XPVLV();
6726         SvCUR(dstr)     = SvCUR(sstr);
6727         SvLEN(dstr)     = SvLEN(sstr);
6728         SvIVX(dstr)     = SvIVX(sstr);
6729         SvNVX(dstr)     = SvNVX(sstr);
6730         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6731         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6732         if (SvROK(sstr))
6733             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6734         else if (SvPVX(sstr) && SvLEN(sstr))
6735             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6736         else
6737             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6738         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
6739         LvTARGLEN(dstr) = LvTARGLEN(sstr);
6740         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
6741         LvTYPE(dstr)    = LvTYPE(sstr);
6742         break;
6743     case SVt_PVGV:
6744         SvANY(dstr)     = new_XPVGV();
6745         SvCUR(dstr)     = SvCUR(sstr);
6746         SvLEN(dstr)     = SvLEN(sstr);
6747         SvIVX(dstr)     = SvIVX(sstr);
6748         SvNVX(dstr)     = SvNVX(sstr);
6749         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6750         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6751         if (SvROK(sstr))
6752             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6753         else if (SvPVX(sstr) && SvLEN(sstr))
6754             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6755         else
6756             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6757         GvNAMELEN(dstr) = GvNAMELEN(sstr);
6758         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6759         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
6760         GvFLAGS(dstr)   = GvFLAGS(sstr);
6761         GvGP(dstr)      = gp_dup(GvGP(sstr));
6762         (void)GpREFCNT_inc(GvGP(dstr));
6763         break;
6764     case SVt_PVIO:
6765         SvANY(dstr)     = new_XPVIO();
6766         SvCUR(dstr)     = SvCUR(sstr);
6767         SvLEN(dstr)     = SvLEN(sstr);
6768         SvIVX(dstr)     = SvIVX(sstr);
6769         SvNVX(dstr)     = SvNVX(sstr);
6770         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6771         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6772         if (SvROK(sstr))
6773             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6774         else if (SvPVX(sstr) && SvLEN(sstr))
6775             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6776         else
6777             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6778         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6779         if (IoOFP(sstr) == IoIFP(sstr))
6780             IoOFP(dstr) = IoIFP(dstr);
6781         else
6782             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6783         /* PL_rsfp_filters entries have fake IoDIRP() */
6784         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6785             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
6786         else
6787             IoDIRP(dstr)        = IoDIRP(sstr);
6788         IoLINES(dstr)           = IoLINES(sstr);
6789         IoPAGE(dstr)            = IoPAGE(sstr);
6790         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
6791         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
6792         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
6793         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
6794         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
6795         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
6796         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
6797         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
6798         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
6799         IoTYPE(dstr)            = IoTYPE(sstr);
6800         IoFLAGS(dstr)           = IoFLAGS(sstr);
6801         break;
6802     case SVt_PVAV:
6803         SvANY(dstr)     = new_XPVAV();
6804         SvCUR(dstr)     = SvCUR(sstr);
6805         SvLEN(dstr)     = SvLEN(sstr);
6806         SvIVX(dstr)     = SvIVX(sstr);
6807         SvNVX(dstr)     = SvNVX(sstr);
6808         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6809         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6810         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6811         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6812         if (AvARRAY((AV*)sstr)) {
6813             SV **dst_ary, **src_ary;
6814             SSize_t items = AvFILLp((AV*)sstr) + 1;
6815
6816             src_ary = AvARRAY((AV*)sstr);
6817             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6818             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6819             SvPVX(dstr) = (char*)dst_ary;
6820             AvALLOC((AV*)dstr) = dst_ary;
6821             if (AvREAL((AV*)sstr)) {
6822                 while (items-- > 0)
6823                     *dst_ary++ = sv_dup_inc(*src_ary++);
6824             }
6825             else {
6826                 while (items-- > 0)
6827                     *dst_ary++ = sv_dup(*src_ary++);
6828             }
6829             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6830             while (items-- > 0) {
6831                 *dst_ary++ = &PL_sv_undef;
6832             }
6833         }
6834         else {
6835             SvPVX(dstr)         = Nullch;
6836             AvALLOC((AV*)dstr)  = (SV**)NULL;
6837         }
6838         break;
6839     case SVt_PVHV:
6840         SvANY(dstr)     = new_XPVHV();
6841         SvCUR(dstr)     = SvCUR(sstr);
6842         SvLEN(dstr)     = SvLEN(sstr);
6843         SvIVX(dstr)     = SvIVX(sstr);
6844         SvNVX(dstr)     = SvNVX(sstr);
6845         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6846         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6847         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
6848         if (HvARRAY((HV*)sstr)) {
6849             HE *entry;
6850             STRLEN i = 0;
6851             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6852             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6853             Newz(0, dxhv->xhv_array,
6854                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6855             while (i <= sxhv->xhv_max) {
6856                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6857                                                     !!HvSHAREKEYS(sstr));
6858                 ++i;
6859             }
6860             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6861         }
6862         else {
6863             SvPVX(dstr)         = Nullch;
6864             HvEITER((HV*)dstr)  = (HE*)NULL;
6865         }
6866         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
6867         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
6868         break;
6869     case SVt_PVFM:
6870         SvANY(dstr)     = new_XPVFM();
6871         FmLINES(dstr)   = FmLINES(sstr);
6872         goto dup_pvcv;
6873         /* NOTREACHED */
6874     case SVt_PVCV:
6875         SvANY(dstr)     = new_XPVCV();
6876 dup_pvcv:
6877         SvCUR(dstr)     = SvCUR(sstr);
6878         SvLEN(dstr)     = SvLEN(sstr);
6879         SvIVX(dstr)     = SvIVX(sstr);
6880         SvNVX(dstr)     = SvNVX(sstr);
6881         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6882         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6883         if (SvPVX(sstr) && SvLEN(sstr))
6884             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6885         else
6886             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6887         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6888         CvSTART(dstr)   = CvSTART(sstr);
6889         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
6890         CvXSUB(dstr)    = CvXSUB(sstr);
6891         CvXSUBANY(dstr) = CvXSUBANY(sstr);
6892         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
6893         CvDEPTH(dstr)   = CvDEPTH(sstr);
6894         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6895             /* XXX padlists are real, but pretend to be not */
6896             AvREAL_on(CvPADLIST(sstr));
6897             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6898             AvREAL_off(CvPADLIST(sstr));
6899             AvREAL_off(CvPADLIST(dstr));
6900         }
6901         else
6902             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6903         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6904         CvFLAGS(dstr)   = CvFLAGS(sstr);
6905         break;
6906     default:
6907         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6908         break;
6909     }
6910
6911     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6912         ++PL_sv_objcount;
6913
6914     return dstr;
6915 }
6916
6917 PERL_CONTEXT *
6918 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6919 {
6920     PERL_CONTEXT *ncxs;
6921
6922     if (!cxs)
6923         return (PERL_CONTEXT*)NULL;
6924
6925     /* look for it in the table first */
6926     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6927     if (ncxs)
6928         return ncxs;
6929
6930     /* create anew and remember what it is */
6931     Newz(56, ncxs, max + 1, PERL_CONTEXT);
6932     ptr_table_store(PL_ptr_table, cxs, ncxs);
6933
6934     while (ix >= 0) {
6935         PERL_CONTEXT *cx = &cxs[ix];
6936         PERL_CONTEXT *ncx = &ncxs[ix];
6937         ncx->cx_type    = cx->cx_type;
6938         if (CxTYPE(cx) == CXt_SUBST) {
6939             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6940         }
6941         else {
6942             ncx->blk_oldsp      = cx->blk_oldsp;
6943             ncx->blk_oldcop     = cx->blk_oldcop;
6944             ncx->blk_oldretsp   = cx->blk_oldretsp;
6945             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
6946             ncx->blk_oldscopesp = cx->blk_oldscopesp;
6947             ncx->blk_oldpm      = cx->blk_oldpm;
6948             ncx->blk_gimme      = cx->blk_gimme;
6949             switch (CxTYPE(cx)) {
6950             case CXt_SUB:
6951                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
6952                                            ? cv_dup_inc(cx->blk_sub.cv)
6953                                            : cv_dup(cx->blk_sub.cv));
6954                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
6955                                            ? av_dup_inc(cx->blk_sub.argarray)
6956                                            : Nullav);
6957                 ncx->blk_sub.savearray  = av_dup(cx->blk_sub.savearray);
6958                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
6959                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
6960                 ncx->blk_sub.lval       = cx->blk_sub.lval;
6961                 break;
6962             case CXt_EVAL:
6963                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6964                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6965                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
6966                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6967                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text);
6968                 break;
6969             case CXt_LOOP:
6970                 ncx->blk_loop.label     = cx->blk_loop.label;
6971                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
6972                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
6973                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
6974                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
6975                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
6976                                            ? cx->blk_loop.iterdata
6977                                            : gv_dup((GV*)cx->blk_loop.iterdata));
6978                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave);
6979                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval);
6980                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary);
6981                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
6982                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
6983                 break;
6984             case CXt_FORMAT:
6985                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv);
6986                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv);
6987                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv);
6988                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
6989                 break;
6990             case CXt_BLOCK:
6991             case CXt_NULL:
6992                 break;
6993             }
6994         }
6995         --ix;
6996     }
6997     return ncxs;
6998 }
6999
7000 PERL_SI *
7001 Perl_si_dup(pTHX_ PERL_SI *si)
7002 {
7003     PERL_SI *nsi;
7004
7005     if (!si)
7006         return (PERL_SI*)NULL;
7007
7008     /* look for it in the table first */
7009     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7010     if (nsi)
7011         return nsi;
7012
7013     /* create anew and remember what it is */
7014     Newz(56, nsi, 1, PERL_SI);
7015     ptr_table_store(PL_ptr_table, si, nsi);
7016
7017     nsi->si_stack       = av_dup_inc(si->si_stack);
7018     nsi->si_cxix        = si->si_cxix;
7019     nsi->si_cxmax       = si->si_cxmax;
7020     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7021     nsi->si_type        = si->si_type;
7022     nsi->si_prev        = si_dup(si->si_prev);
7023     nsi->si_next        = si_dup(si->si_next);
7024     nsi->si_markoff     = si->si_markoff;
7025
7026     return nsi;
7027 }
7028
7029 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
7030 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
7031 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
7032 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
7033 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
7034 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
7035 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
7036 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
7037 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
7038 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
7039 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7040 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7041
7042 /* XXXXX todo */
7043 #define pv_dup_inc(p)   SAVEPV(p)
7044 #define pv_dup(p)       SAVEPV(p)
7045 #define svp_dup_inc(p,pp)       any_dup(p,pp)
7046
7047 void *
7048 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7049 {
7050     void *ret;
7051
7052     if (!v)
7053         return (void*)NULL;
7054
7055     /* look for it in the table first */
7056     ret = ptr_table_fetch(PL_ptr_table, v);
7057     if (ret)
7058         return ret;
7059
7060     /* see if it is part of the interpreter structure */
7061     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7062         ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7063     else
7064         ret = v;
7065
7066     return ret;
7067 }
7068
7069 ANY *
7070 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7071 {
7072     ANY *ss     = proto_perl->Tsavestack;
7073     I32 ix      = proto_perl->Tsavestack_ix;
7074     I32 max     = proto_perl->Tsavestack_max;
7075     ANY *nss;
7076     SV *sv;
7077     GV *gv;
7078     AV *av;
7079     HV *hv;
7080     void* ptr;
7081     int intval;
7082     long longval;
7083     GP *gp;
7084     IV iv;
7085     I32 i;
7086     char *c;
7087     void (*dptr) (void*);
7088     void (*dxptr) (pTHXo_ void*);
7089
7090     Newz(54, nss, max, ANY);
7091
7092     while (ix > 0) {
7093         i = POPINT(ss,ix);
7094         TOPINT(nss,ix) = i;
7095         switch (i) {
7096         case SAVEt_ITEM:                        /* normal string */
7097             sv = (SV*)POPPTR(ss,ix);
7098             TOPPTR(nss,ix) = sv_dup_inc(sv);
7099             sv = (SV*)POPPTR(ss,ix);
7100             TOPPTR(nss,ix) = sv_dup_inc(sv);
7101             break;
7102         case SAVEt_SV:                          /* scalar reference */
7103             sv = (SV*)POPPTR(ss,ix);
7104             TOPPTR(nss,ix) = sv_dup_inc(sv);
7105             gv = (GV*)POPPTR(ss,ix);
7106             TOPPTR(nss,ix) = gv_dup_inc(gv);
7107             break;
7108         case SAVEt_GENERIC_SVREF:               /* generic sv */
7109         case SAVEt_SVREF:                       /* scalar reference */
7110             sv = (SV*)POPPTR(ss,ix);
7111             TOPPTR(nss,ix) = sv_dup_inc(sv);
7112             ptr = POPPTR(ss,ix);
7113             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7114             break;
7115         case SAVEt_AV:                          /* array reference */
7116             av = (AV*)POPPTR(ss,ix);
7117             TOPPTR(nss,ix) = av_dup_inc(av);
7118             gv = (GV*)POPPTR(ss,ix);
7119             TOPPTR(nss,ix) = gv_dup(gv);
7120             break;
7121         case SAVEt_HV:                          /* hash reference */
7122             hv = (HV*)POPPTR(ss,ix);
7123             TOPPTR(nss,ix) = hv_dup_inc(hv);
7124             gv = (GV*)POPPTR(ss,ix);
7125             TOPPTR(nss,ix) = gv_dup(gv);
7126             break;
7127         case SAVEt_INT:                         /* int reference */
7128             ptr = POPPTR(ss,ix);
7129             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7130             intval = (int)POPINT(ss,ix);
7131             TOPINT(nss,ix) = intval;
7132             break;
7133         case SAVEt_LONG:                        /* long reference */
7134             ptr = POPPTR(ss,ix);
7135             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7136             longval = (long)POPLONG(ss,ix);
7137             TOPLONG(nss,ix) = longval;
7138             break;
7139         case SAVEt_I32:                         /* I32 reference */
7140         case SAVEt_I16:                         /* I16 reference */
7141         case SAVEt_I8:                          /* I8 reference */
7142             ptr = POPPTR(ss,ix);
7143             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7144             i = POPINT(ss,ix);
7145             TOPINT(nss,ix) = i;
7146             break;
7147         case SAVEt_IV:                          /* IV reference */
7148             ptr = POPPTR(ss,ix);
7149             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7150             iv = POPIV(ss,ix);
7151             TOPIV(nss,ix) = iv;
7152             break;
7153         case SAVEt_SPTR:                        /* SV* reference */
7154             ptr = POPPTR(ss,ix);
7155             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7156             sv = (SV*)POPPTR(ss,ix);
7157             TOPPTR(nss,ix) = sv_dup(sv);
7158             break;
7159         case SAVEt_VPTR:                        /* random* reference */
7160             ptr = POPPTR(ss,ix);
7161             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7162             ptr = POPPTR(ss,ix);
7163             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7164             break;
7165         case SAVEt_PPTR:                        /* char* reference */
7166             ptr = POPPTR(ss,ix);
7167             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7168             c = (char*)POPPTR(ss,ix);
7169             TOPPTR(nss,ix) = pv_dup(c);
7170             break;
7171         case SAVEt_HPTR:                        /* HV* reference */
7172             ptr = POPPTR(ss,ix);
7173             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7174             hv = (HV*)POPPTR(ss,ix);
7175             TOPPTR(nss,ix) = hv_dup(hv);
7176             break;
7177         case SAVEt_APTR:                        /* AV* reference */
7178             ptr = POPPTR(ss,ix);
7179             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7180             av = (AV*)POPPTR(ss,ix);
7181             TOPPTR(nss,ix) = av_dup(av);
7182             break;
7183         case SAVEt_NSTAB:
7184             gv = (GV*)POPPTR(ss,ix);
7185             TOPPTR(nss,ix) = gv_dup(gv);
7186             break;
7187         case SAVEt_GP:                          /* scalar reference */
7188             gp = (GP*)POPPTR(ss,ix);
7189             TOPPTR(nss,ix) = gp = gp_dup(gp);
7190             (void)GpREFCNT_inc(gp);
7191             gv = (GV*)POPPTR(ss,ix);
7192             TOPPTR(nss,ix) = gv_dup_inc(c);
7193             c = (char*)POPPTR(ss,ix);
7194             TOPPTR(nss,ix) = pv_dup(c);
7195             iv = POPIV(ss,ix);
7196             TOPIV(nss,ix) = iv;
7197             iv = POPIV(ss,ix);
7198             TOPIV(nss,ix) = iv;
7199             break;
7200         case SAVEt_FREESV:
7201             sv = (SV*)POPPTR(ss,ix);
7202             TOPPTR(nss,ix) = sv_dup_inc(sv);
7203             break;
7204         case SAVEt_FREEOP:
7205             ptr = POPPTR(ss,ix);
7206             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7207                 /* these are assumed to be refcounted properly */
7208                 switch (((OP*)ptr)->op_type) {
7209                 case OP_LEAVESUB:
7210                 case OP_LEAVESUBLV:
7211                 case OP_LEAVEEVAL:
7212                 case OP_LEAVE:
7213                 case OP_SCOPE:
7214                 case OP_LEAVEWRITE:
7215                     TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7216                     break;
7217                 default:
7218                     TOPPTR(nss,ix) = Nullop;
7219                     break;
7220                 }
7221             }
7222             else
7223                 TOPPTR(nss,ix) = Nullop;
7224             break;
7225         case SAVEt_FREEPV:
7226             c = (char*)POPPTR(ss,ix);
7227             TOPPTR(nss,ix) = pv_dup_inc(c);
7228             break;
7229         case SAVEt_CLEARSV:
7230             longval = POPLONG(ss,ix);
7231             TOPLONG(nss,ix) = longval;
7232             break;
7233         case SAVEt_DELETE:
7234             hv = (HV*)POPPTR(ss,ix);
7235             TOPPTR(nss,ix) = hv_dup_inc(hv);
7236             c = (char*)POPPTR(ss,ix);
7237             TOPPTR(nss,ix) = pv_dup_inc(c);
7238             i = POPINT(ss,ix);
7239             TOPINT(nss,ix) = i;
7240             break;
7241         case SAVEt_DESTRUCTOR:
7242             ptr = POPPTR(ss,ix);
7243             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
7244             dptr = POPDPTR(ss,ix);
7245             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7246             break;
7247         case SAVEt_DESTRUCTOR_X:
7248             ptr = POPPTR(ss,ix);
7249             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
7250             dxptr = POPDXPTR(ss,ix);
7251             TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7252             break;
7253         case SAVEt_REGCONTEXT:
7254         case SAVEt_ALLOC:
7255             i = POPINT(ss,ix);
7256             TOPINT(nss,ix) = i;
7257             ix -= i;
7258             break;
7259         case SAVEt_STACK_POS:           /* Position on Perl stack */
7260             i = POPINT(ss,ix);
7261             TOPINT(nss,ix) = i;
7262             break;
7263         case SAVEt_AELEM:               /* array element */
7264             sv = (SV*)POPPTR(ss,ix);
7265             TOPPTR(nss,ix) = sv_dup_inc(sv);
7266             i = POPINT(ss,ix);
7267             TOPINT(nss,ix) = i;
7268             av = (AV*)POPPTR(ss,ix);
7269             TOPPTR(nss,ix) = av_dup_inc(av);
7270             break;
7271         case SAVEt_HELEM:               /* hash element */
7272             sv = (SV*)POPPTR(ss,ix);
7273             TOPPTR(nss,ix) = sv_dup_inc(sv);
7274             sv = (SV*)POPPTR(ss,ix);
7275             TOPPTR(nss,ix) = sv_dup_inc(sv);
7276             hv = (HV*)POPPTR(ss,ix);
7277             TOPPTR(nss,ix) = hv_dup_inc(hv);
7278             break;
7279         case SAVEt_OP:
7280             ptr = POPPTR(ss,ix);
7281             TOPPTR(nss,ix) = ptr;
7282             break;
7283         case SAVEt_HINTS:
7284             i = POPINT(ss,ix);
7285             TOPINT(nss,ix) = i;
7286             break;
7287         case SAVEt_COMPPAD:
7288             av = (AV*)POPPTR(ss,ix);
7289             TOPPTR(nss,ix) = av_dup(av);
7290             break;
7291         default:
7292             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7293         }
7294     }
7295
7296     return nss;
7297 }
7298
7299 #ifdef PERL_OBJECT
7300 #include "XSUB.h"
7301 #endif
7302
7303 PerlInterpreter *
7304 perl_clone(PerlInterpreter *proto_perl, UV flags)
7305 {
7306 #ifdef PERL_OBJECT
7307     CPerlObj *pPerl = (CPerlObj*)proto_perl;
7308 #endif
7309
7310 #ifdef PERL_IMPLICIT_SYS
7311     return perl_clone_using(proto_perl, flags,
7312                             proto_perl->IMem,
7313                             proto_perl->IMemShared,
7314                             proto_perl->IMemParse,
7315                             proto_perl->IEnv,
7316                             proto_perl->IStdIO,
7317                             proto_perl->ILIO,
7318                             proto_perl->IDir,
7319                             proto_perl->ISock,
7320                             proto_perl->IProc);
7321 }
7322
7323 PerlInterpreter *
7324 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7325                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
7326                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7327                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7328                  struct IPerlDir* ipD, struct IPerlSock* ipS,
7329                  struct IPerlProc* ipP)
7330 {
7331     /* XXX many of the string copies here can be optimized if they're
7332      * constants; they need to be allocated as common memory and just
7333      * their pointers copied. */
7334
7335     IV i;
7336     SV *sv;
7337     SV **svp;
7338 #  ifdef PERL_OBJECT
7339     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7340                                         ipD, ipS, ipP);
7341     PERL_SET_INTERP(pPerl);
7342 #  else         /* !PERL_OBJECT */
7343     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7344     PERL_SET_INTERP(my_perl);
7345
7346 #    ifdef DEBUGGING
7347     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7348     PL_markstack = 0;
7349     PL_scopestack = 0;
7350     PL_savestack = 0;
7351     PL_retstack = 0;
7352 #    else       /* !DEBUGGING */
7353     Zero(my_perl, 1, PerlInterpreter);
7354 #    endif      /* DEBUGGING */
7355
7356     /* host pointers */
7357     PL_Mem              = ipM;
7358     PL_MemShared        = ipMS;
7359     PL_MemParse         = ipMP;
7360     PL_Env              = ipE;
7361     PL_StdIO            = ipStd;
7362     PL_LIO              = ipLIO;
7363     PL_Dir              = ipD;
7364     PL_Sock             = ipS;
7365     PL_Proc             = ipP;
7366 #  endif        /* PERL_OBJECT */
7367 #else           /* !PERL_IMPLICIT_SYS */
7368     IV i;
7369     SV *sv;
7370     SV **svp;
7371     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7372     PERL_SET_INTERP(my_perl);
7373
7374 #    ifdef DEBUGGING
7375     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7376     PL_markstack = 0;
7377     PL_scopestack = 0;
7378     PL_savestack = 0;
7379     PL_retstack = 0;
7380 #    else       /* !DEBUGGING */
7381     Zero(my_perl, 1, PerlInterpreter);
7382 #    endif      /* DEBUGGING */
7383 #endif          /* PERL_IMPLICIT_SYS */
7384
7385     /* arena roots */
7386     PL_xiv_arenaroot    = NULL;
7387     PL_xiv_root         = NULL;
7388     PL_xnv_root         = NULL;
7389     PL_xrv_root         = NULL;
7390     PL_xpv_root         = NULL;
7391     PL_xpviv_root       = NULL;
7392     PL_xpvnv_root       = NULL;
7393     PL_xpvcv_root       = NULL;
7394     PL_xpvav_root       = NULL;
7395     PL_xpvhv_root       = NULL;
7396     PL_xpvmg_root       = NULL;
7397     PL_xpvlv_root       = NULL;
7398     PL_xpvbm_root       = NULL;
7399     PL_he_root          = NULL;
7400     PL_nice_chunk       = NULL;
7401     PL_nice_chunk_size  = 0;
7402     PL_sv_count         = 0;
7403     PL_sv_objcount      = 0;
7404     PL_sv_root          = Nullsv;
7405     PL_sv_arenaroot     = Nullsv;
7406
7407     PL_debug            = proto_perl->Idebug;
7408
7409     /* create SV map for pointer relocation */
7410     PL_ptr_table = ptr_table_new();
7411
7412     /* initialize these special pointers as early as possible */
7413     SvANY(&PL_sv_undef)         = NULL;
7414     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
7415     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
7416     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7417
7418 #ifdef PERL_OBJECT
7419     SvUPGRADE(&PL_sv_no, SVt_PVNV);
7420 #else
7421     SvANY(&PL_sv_no)            = new_XPVNV();
7422 #endif
7423     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
7424     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7425     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
7426     SvCUR(&PL_sv_no)            = 0;
7427     SvLEN(&PL_sv_no)            = 1;
7428     SvNVX(&PL_sv_no)            = 0;
7429     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7430
7431 #ifdef PERL_OBJECT
7432     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7433 #else
7434     SvANY(&PL_sv_yes)           = new_XPVNV();
7435 #endif
7436     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
7437     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7438     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
7439     SvCUR(&PL_sv_yes)           = 1;
7440     SvLEN(&PL_sv_yes)           = 2;
7441     SvNVX(&PL_sv_yes)           = 1;
7442     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7443
7444     /* create shared string table */
7445     PL_strtab           = newHV();
7446     HvSHAREKEYS_off(PL_strtab);
7447     hv_ksplit(PL_strtab, 512);
7448     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7449
7450     PL_compiling                = proto_perl->Icompiling;
7451     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
7452     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
7453     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7454     if (!specialWARN(PL_compiling.cop_warnings))
7455         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7456     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7457
7458     /* pseudo environmental stuff */
7459     PL_origargc         = proto_perl->Iorigargc;
7460     i = PL_origargc;
7461     New(0, PL_origargv, i+1, char*);
7462     PL_origargv[i] = '\0';
7463     while (i-- > 0) {
7464         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
7465     }
7466     PL_envgv            = gv_dup(proto_perl->Ienvgv);
7467     PL_incgv            = gv_dup(proto_perl->Iincgv);
7468     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
7469     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
7470     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
7471     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
7472
7473     /* switches */
7474     PL_minus_c          = proto_perl->Iminus_c;
7475     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
7476     PL_localpatches     = proto_perl->Ilocalpatches;
7477     PL_splitstr         = proto_perl->Isplitstr;
7478     PL_preprocess       = proto_perl->Ipreprocess;
7479     PL_minus_n          = proto_perl->Iminus_n;
7480     PL_minus_p          = proto_perl->Iminus_p;
7481     PL_minus_l          = proto_perl->Iminus_l;
7482     PL_minus_a          = proto_perl->Iminus_a;
7483     PL_minus_F          = proto_perl->Iminus_F;
7484     PL_doswitches       = proto_perl->Idoswitches;
7485     PL_dowarn           = proto_perl->Idowarn;
7486     PL_doextract        = proto_perl->Idoextract;
7487     PL_sawampersand     = proto_perl->Isawampersand;
7488     PL_unsafe           = proto_perl->Iunsafe;
7489     PL_inplace          = SAVEPV(proto_perl->Iinplace);
7490     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
7491     PL_perldb           = proto_perl->Iperldb;
7492     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7493
7494     /* magical thingies */
7495     /* XXX time(&PL_basetime) when asked for? */
7496     PL_basetime         = proto_perl->Ibasetime;
7497     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
7498
7499     PL_maxsysfd         = proto_perl->Imaxsysfd;
7500     PL_multiline        = proto_perl->Imultiline;
7501     PL_statusvalue      = proto_perl->Istatusvalue;
7502 #ifdef VMS
7503     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
7504 #endif
7505
7506     /* shortcuts to various I/O objects */
7507     PL_stdingv          = gv_dup(proto_perl->Istdingv);
7508     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
7509     PL_defgv            = gv_dup(proto_perl->Idefgv);
7510     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
7511     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
7512     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
7513
7514     /* shortcuts to regexp stuff */
7515     PL_replgv           = gv_dup(proto_perl->Ireplgv);
7516
7517     /* shortcuts to misc objects */
7518     PL_errgv            = gv_dup(proto_perl->Ierrgv);
7519
7520     /* shortcuts to debugging objects */
7521     PL_DBgv             = gv_dup(proto_perl->IDBgv);
7522     PL_DBline           = gv_dup(proto_perl->IDBline);
7523     PL_DBsub            = gv_dup(proto_perl->IDBsub);
7524     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
7525     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
7526     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
7527     PL_lineary          = av_dup(proto_perl->Ilineary);
7528     PL_dbargs           = av_dup(proto_perl->Idbargs);
7529
7530     /* symbol tables */
7531     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
7532     PL_curstash         = hv_dup(proto_perl->Tcurstash);
7533     PL_debstash         = hv_dup(proto_perl->Idebstash);
7534     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
7535     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
7536
7537     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
7538     PL_endav            = av_dup_inc(proto_perl->Iendav);
7539     PL_checkav          = av_dup_inc(proto_perl->Icheckav);
7540     PL_initav           = av_dup_inc(proto_perl->Iinitav);
7541
7542     PL_sub_generation   = proto_perl->Isub_generation;
7543
7544     /* funky return mechanisms */
7545     PL_forkprocess      = proto_perl->Iforkprocess;
7546
7547     /* subprocess state */
7548     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
7549
7550     /* internal state */
7551     PL_tainting         = proto_perl->Itainting;
7552     PL_maxo             = proto_perl->Imaxo;
7553     if (proto_perl->Iop_mask)
7554         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7555     else
7556         PL_op_mask      = Nullch;
7557
7558     /* current interpreter roots */
7559     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
7560     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
7561     PL_main_start       = proto_perl->Imain_start;
7562     PL_eval_root        = OpREFCNT_inc(proto_perl->Ieval_root);
7563     PL_eval_start       = proto_perl->Ieval_start;
7564
7565     /* runtime control stuff */
7566     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7567     PL_copline          = proto_perl->Icopline;
7568
7569     PL_filemode         = proto_perl->Ifilemode;
7570     PL_lastfd           = proto_perl->Ilastfd;
7571     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
7572     PL_Argv             = NULL;
7573     PL_Cmd              = Nullch;
7574     PL_gensym           = proto_perl->Igensym;
7575     PL_preambled        = proto_perl->Ipreambled;
7576     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
7577     PL_laststatval      = proto_perl->Ilaststatval;
7578     PL_laststype        = proto_perl->Ilaststype;
7579     PL_mess_sv          = Nullsv;
7580
7581     PL_orslen           = proto_perl->Iorslen;
7582     PL_ors              = SAVEPVN(proto_perl->Iors, PL_orslen);
7583     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
7584
7585     /* interpreter atexit processing */
7586     PL_exitlistlen      = proto_perl->Iexitlistlen;
7587     if (PL_exitlistlen) {
7588         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7589         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7590     }
7591     else
7592         PL_exitlist     = (PerlExitListEntry*)NULL;
7593     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
7594
7595     PL_profiledata      = NULL;
7596     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
7597     /* PL_rsfp_filters entries have fake IoDIRP() */
7598     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
7599
7600     PL_compcv                   = cv_dup(proto_perl->Icompcv);
7601     PL_comppad                  = av_dup(proto_perl->Icomppad);
7602     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
7603     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
7604     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
7605     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
7606                                                         proto_perl->Tcurpad);
7607
7608 #ifdef HAVE_INTERP_INTERN
7609     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7610 #endif
7611
7612     /* more statics moved here */
7613     PL_generation       = proto_perl->Igeneration;
7614     PL_DBcv             = cv_dup(proto_perl->IDBcv);
7615
7616     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
7617     PL_in_clean_all     = proto_perl->Iin_clean_all;
7618
7619     PL_uid              = proto_perl->Iuid;
7620     PL_euid             = proto_perl->Ieuid;
7621     PL_gid              = proto_perl->Igid;
7622     PL_egid             = proto_perl->Iegid;
7623     PL_nomemok          = proto_perl->Inomemok;
7624     PL_an               = proto_perl->Ian;
7625     PL_cop_seqmax       = proto_perl->Icop_seqmax;
7626     PL_op_seqmax        = proto_perl->Iop_seqmax;
7627     PL_evalseq          = proto_perl->Ievalseq;
7628     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
7629     PL_origalen         = proto_perl->Iorigalen;
7630     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
7631     PL_osname           = SAVEPV(proto_perl->Iosname);
7632     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
7633     PL_sighandlerp      = proto_perl->Isighandlerp;
7634
7635
7636     PL_runops           = proto_perl->Irunops;
7637
7638     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7639
7640 #ifdef CSH
7641     PL_cshlen           = proto_perl->Icshlen;
7642     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7643 #endif
7644
7645     PL_lex_state        = proto_perl->Ilex_state;
7646     PL_lex_defer        = proto_perl->Ilex_defer;
7647     PL_lex_expect       = proto_perl->Ilex_expect;
7648     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
7649     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
7650     PL_lex_starts       = proto_perl->Ilex_starts;
7651     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
7652     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
7653     PL_lex_op           = proto_perl->Ilex_op;
7654     PL_lex_inpat        = proto_perl->Ilex_inpat;
7655     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
7656     PL_lex_brackets     = proto_perl->Ilex_brackets;
7657     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7658     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
7659     PL_lex_casemods     = proto_perl->Ilex_casemods;
7660     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7661     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
7662
7663     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7664     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7665     PL_nexttoke         = proto_perl->Inexttoke;
7666
7667     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
7668     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7669     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7670     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7671     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7672     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7673     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7674     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7675     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7676     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7677     PL_pending_ident    = proto_perl->Ipending_ident;
7678     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
7679
7680     PL_expect           = proto_perl->Iexpect;
7681
7682     PL_multi_start      = proto_perl->Imulti_start;
7683     PL_multi_end        = proto_perl->Imulti_end;
7684     PL_multi_open       = proto_perl->Imulti_open;
7685     PL_multi_close      = proto_perl->Imulti_close;
7686
7687     PL_error_count      = proto_perl->Ierror_count;
7688     PL_subline          = proto_perl->Isubline;
7689     PL_subname          = sv_dup_inc(proto_perl->Isubname);
7690
7691     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
7692     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
7693     PL_padix                    = proto_perl->Ipadix;
7694     PL_padix_floor              = proto_perl->Ipadix_floor;
7695     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
7696
7697     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7698     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7699     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7700     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7701     PL_last_lop_op      = proto_perl->Ilast_lop_op;
7702     PL_in_my            = proto_perl->Iin_my;
7703     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
7704 #ifdef FCRYPT
7705     PL_cryptseen        = proto_perl->Icryptseen;
7706 #endif
7707
7708     PL_hints            = proto_perl->Ihints;
7709
7710     PL_amagic_generation        = proto_perl->Iamagic_generation;
7711
7712 #ifdef USE_LOCALE_COLLATE
7713     PL_collation_ix     = proto_perl->Icollation_ix;
7714     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
7715     PL_collation_standard       = proto_perl->Icollation_standard;
7716     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
7717     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
7718 #endif /* USE_LOCALE_COLLATE */
7719
7720 #ifdef USE_LOCALE_NUMERIC
7721     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
7722     PL_numeric_standard = proto_perl->Inumeric_standard;
7723     PL_numeric_local    = proto_perl->Inumeric_local;
7724     PL_numeric_radix    = proto_perl->Inumeric_radix;
7725 #endif /* !USE_LOCALE_NUMERIC */
7726
7727     /* utf8 character classes */
7728     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
7729     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
7730     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
7731     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
7732     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
7733     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
7734     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
7735     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
7736     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
7737     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
7738     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
7739     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
7740     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
7741     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
7742     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
7743     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
7744     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
7745
7746     /* swatch cache */
7747     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
7748     PL_last_swash_klen  = 0;
7749     PL_last_swash_key[0]= '\0';
7750     PL_last_swash_tmps  = (U8*)NULL;
7751     PL_last_swash_slen  = 0;
7752
7753     /* perly.c globals */
7754     PL_yydebug          = proto_perl->Iyydebug;
7755     PL_yynerrs          = proto_perl->Iyynerrs;
7756     PL_yyerrflag        = proto_perl->Iyyerrflag;
7757     PL_yychar           = proto_perl->Iyychar;
7758     PL_yyval            = proto_perl->Iyyval;
7759     PL_yylval           = proto_perl->Iyylval;
7760
7761     PL_glob_index       = proto_perl->Iglob_index;
7762     PL_srand_called     = proto_perl->Isrand_called;
7763     PL_uudmap['M']      = 0;            /* reinits on demand */
7764     PL_bitcount         = Nullch;       /* reinits on demand */
7765
7766     if (proto_perl->Ipsig_ptr) {
7767         int sig_num[] = { SIG_NUM };
7768         Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7769         Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7770         for (i = 1; PL_sig_name[i]; i++) {
7771             PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7772             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7773         }
7774     }
7775     else {
7776         PL_psig_ptr     = (SV**)NULL;
7777         PL_psig_name    = (SV**)NULL;
7778     }
7779
7780     /* thrdvar.h stuff */
7781
7782     if (flags & 1) {
7783         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7784         PL_tmps_ix              = proto_perl->Ttmps_ix;
7785         PL_tmps_max             = proto_perl->Ttmps_max;
7786         PL_tmps_floor           = proto_perl->Ttmps_floor;
7787         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7788         i = 0;
7789         while (i <= PL_tmps_ix) {
7790             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7791             ++i;
7792         }
7793
7794         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7795         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7796         Newz(54, PL_markstack, i, I32);
7797         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
7798                                                   - proto_perl->Tmarkstack);
7799         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
7800                                                   - proto_perl->Tmarkstack);
7801         Copy(proto_perl->Tmarkstack, PL_markstack,
7802              PL_markstack_ptr - PL_markstack + 1, I32);
7803
7804         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7805          * NOTE: unlike the others! */
7806         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
7807         PL_scopestack_max       = proto_perl->Tscopestack_max;
7808         Newz(54, PL_scopestack, PL_scopestack_max, I32);
7809         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7810
7811         /* next push_return() sets PL_retstack[PL_retstack_ix]
7812          * NOTE: unlike the others! */
7813         PL_retstack_ix          = proto_perl->Tretstack_ix;
7814         PL_retstack_max         = proto_perl->Tretstack_max;
7815         Newz(54, PL_retstack, PL_retstack_max, OP*);
7816         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7817
7818         /* NOTE: si_dup() looks at PL_markstack */
7819         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
7820
7821         /* PL_curstack          = PL_curstackinfo->si_stack; */
7822         PL_curstack             = av_dup(proto_perl->Tcurstack);
7823         PL_mainstack            = av_dup(proto_perl->Tmainstack);
7824
7825         /* next PUSHs() etc. set *(PL_stack_sp+1) */
7826         PL_stack_base           = AvARRAY(PL_curstack);
7827         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
7828                                                    - proto_perl->Tstack_base);
7829         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
7830
7831         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7832          * NOTE: unlike the others! */
7833         PL_savestack_ix         = proto_perl->Tsavestack_ix;
7834         PL_savestack_max        = proto_perl->Tsavestack_max;
7835         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7836         PL_savestack            = ss_dup(proto_perl);
7837     }
7838     else {
7839         init_stacks();
7840     }
7841
7842     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
7843     PL_top_env          = &PL_start_env;
7844
7845     PL_op               = proto_perl->Top;
7846
7847     PL_Sv               = Nullsv;
7848     PL_Xpv              = (XPV*)NULL;
7849     PL_na               = proto_perl->Tna;
7850
7851     PL_statbuf          = proto_perl->Tstatbuf;
7852     PL_statcache        = proto_perl->Tstatcache;
7853     PL_statgv           = gv_dup(proto_perl->Tstatgv);
7854     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
7855 #ifdef HAS_TIMES
7856     PL_timesbuf         = proto_perl->Ttimesbuf;
7857 #endif
7858
7859     PL_tainted          = proto_perl->Ttainted;
7860     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
7861     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
7862     PL_rs               = sv_dup_inc(proto_perl->Trs);
7863     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
7864     PL_ofslen           = proto_perl->Tofslen;
7865     PL_ofs              = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7866     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
7867     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
7868     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
7869     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
7870     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
7871
7872     PL_restartop        = proto_perl->Trestartop;
7873     PL_in_eval          = proto_perl->Tin_eval;
7874     PL_delaymagic       = proto_perl->Tdelaymagic;
7875     PL_dirty            = proto_perl->Tdirty;
7876     PL_localizing       = proto_perl->Tlocalizing;
7877
7878 #ifdef PERL_FLEXIBLE_EXCEPTIONS
7879     PL_protect          = proto_perl->Tprotect;
7880 #endif
7881     PL_errors           = sv_dup_inc(proto_perl->Terrors);
7882     PL_av_fetch_sv      = Nullsv;
7883     PL_hv_fetch_sv      = Nullsv;
7884     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
7885     PL_modcount         = proto_perl->Tmodcount;
7886     PL_lastgotoprobe    = Nullop;
7887     PL_dumpindent       = proto_perl->Tdumpindent;
7888
7889     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7890     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
7891     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
7892     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
7893     PL_sortcxix         = proto_perl->Tsortcxix;
7894     PL_efloatbuf        = Nullch;               /* reinits on demand */
7895     PL_efloatsize       = 0;                    /* reinits on demand */
7896
7897     /* regex stuff */
7898
7899     PL_screamfirst      = NULL;
7900     PL_screamnext       = NULL;
7901     PL_maxscream        = -1;                   /* reinits on demand */
7902     PL_lastscream       = Nullsv;
7903
7904     PL_watchaddr        = NULL;
7905     PL_watchok          = Nullch;
7906
7907     PL_regdummy         = proto_perl->Tregdummy;
7908     PL_regcomp_parse    = Nullch;
7909     PL_regxend          = Nullch;
7910     PL_regcode          = (regnode*)NULL;
7911     PL_regnaughty       = 0;
7912     PL_regsawback       = 0;
7913     PL_regprecomp       = Nullch;
7914     PL_regnpar          = 0;
7915     PL_regsize          = 0;
7916     PL_regflags         = 0;
7917     PL_regseen          = 0;
7918     PL_seen_zerolen     = 0;
7919     PL_seen_evals       = 0;
7920     PL_regcomp_rx       = (regexp*)NULL;
7921     PL_extralen         = 0;
7922     PL_colorset         = 0;            /* reinits PL_colors[] */
7923     /*PL_colors[6]      = {0,0,0,0,0,0};*/
7924     PL_reg_whilem_seen  = 0;
7925     PL_reginput         = Nullch;
7926     PL_regbol           = Nullch;
7927     PL_regeol           = Nullch;
7928     PL_regstartp        = (I32*)NULL;
7929     PL_regendp          = (I32*)NULL;
7930     PL_reglastparen     = (U32*)NULL;
7931     PL_regtill          = Nullch;
7932     PL_regprev          = '\n';
7933     PL_reg_start_tmp    = (char**)NULL;
7934     PL_reg_start_tmpl   = 0;
7935     PL_regdata          = (struct reg_data*)NULL;
7936     PL_bostr            = Nullch;
7937     PL_reg_flags        = 0;
7938     PL_reg_eval_set     = 0;
7939     PL_regnarrate       = 0;
7940     PL_regprogram       = (regnode*)NULL;
7941     PL_regindent        = 0;
7942     PL_regcc            = (CURCUR*)NULL;
7943     PL_reg_call_cc      = (struct re_cc_state*)NULL;
7944     PL_reg_re           = (regexp*)NULL;
7945     PL_reg_ganch        = Nullch;
7946     PL_reg_sv           = Nullsv;
7947     PL_reg_magic        = (MAGIC*)NULL;
7948     PL_reg_oldpos       = 0;
7949     PL_reg_oldcurpm     = (PMOP*)NULL;
7950     PL_reg_curpm        = (PMOP*)NULL;
7951     PL_reg_oldsaved     = Nullch;
7952     PL_reg_oldsavedlen  = 0;
7953     PL_reg_maxiter      = 0;
7954     PL_reg_leftiter     = 0;
7955     PL_reg_poscache     = Nullch;
7956     PL_reg_poscache_size= 0;
7957
7958     /* RE engine - function pointers */
7959     PL_regcompp         = proto_perl->Tregcompp;
7960     PL_regexecp         = proto_perl->Tregexecp;
7961     PL_regint_start     = proto_perl->Tregint_start;
7962     PL_regint_string    = proto_perl->Tregint_string;
7963     PL_regfree          = proto_perl->Tregfree;
7964
7965     PL_reginterp_cnt    = 0;
7966     PL_reg_starttry     = 0;
7967
7968 #ifdef PERL_OBJECT
7969     return (PerlInterpreter*)pPerl;
7970 #else
7971     return my_perl;
7972 #endif
7973 }
7974
7975 #else   /* !USE_ITHREADS */
7976
7977 #ifdef PERL_OBJECT
7978 #include "XSUB.h"
7979 #endif
7980
7981 #endif /* USE_ITHREADS */
7982
7983 static void
7984 do_report_used(pTHXo_ SV *sv)
7985 {
7986     if (SvTYPE(sv) != SVTYPEMASK) {
7987         PerlIO_printf(Perl_debug_log, "****\n");
7988         sv_dump(sv);
7989     }
7990 }
7991
7992 static void
7993 do_clean_objs(pTHXo_ SV *sv)
7994 {
7995     SV* rv;
7996
7997     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7998         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7999         SvROK_off(sv);
8000         SvRV(sv) = 0;
8001         SvREFCNT_dec(rv);
8002     }
8003
8004     /* XXX Might want to check arrays, etc. */
8005 }
8006
8007 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8008 static void
8009 do_clean_named_objs(pTHXo_ SV *sv)
8010 {
8011     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8012         if ( SvOBJECT(GvSV(sv)) ||
8013              GvAV(sv) && SvOBJECT(GvAV(sv)) ||
8014              GvHV(sv) && SvOBJECT(GvHV(sv)) ||
8015              GvIO(sv) && SvOBJECT(GvIO(sv)) ||
8016              GvCV(sv) && SvOBJECT(GvCV(sv)) )
8017         {
8018             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8019             SvREFCNT_dec(sv);
8020         }
8021     }
8022 }
8023 #endif
8024
8025 static void
8026 do_clean_all(pTHXo_ SV *sv)
8027 {
8028     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8029     SvFLAGS(sv) |= SVf_BREAK;
8030     SvREFCNT_dec(sv);
8031 }
8032