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)Perl_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                 static char const my_prifldbl[] = PERL_PRIfldbl;
6234                 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6235                 while (p >= my_prifldbl) { *--eptr = *p--; }
6236             }
6237 #endif
6238             if (has_precis) {
6239                 base = precis;
6240                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6241                 *--eptr = '.';
6242             }
6243             if (width) {
6244                 base = width;
6245                 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6246             }
6247             if (fill == '0')
6248                 *--eptr = fill;
6249             if (left)
6250                 *--eptr = '-';
6251             if (plus)
6252                 *--eptr = plus;
6253             if (alt)
6254                 *--eptr = '#';
6255             *--eptr = '%';
6256
6257             {
6258                 RESTORE_NUMERIC_STANDARD();
6259                 (void)sprintf(PL_efloatbuf, eptr, nv);
6260                 RESTORE_NUMERIC_LOCAL();
6261             }
6262
6263             eptr = PL_efloatbuf;
6264             elen = strlen(PL_efloatbuf);
6265             break;
6266
6267             /* SPECIAL */
6268
6269         case 'n':
6270             vectorize = FALSE;
6271             i = SvCUR(sv) - origlen;
6272             if (args) {
6273                 switch (intsize) {
6274                 case 'h':       *(va_arg(*args, short*)) = i; break;
6275                 default:        *(va_arg(*args, int*)) = i; break;
6276                 case 'l':       *(va_arg(*args, long*)) = i; break;
6277                 case 'V':       *(va_arg(*args, IV*)) = i; break;
6278 #ifdef HAS_QUAD
6279                 case 'q':       *(va_arg(*args, Quad_t*)) = i; break;
6280 #endif
6281                 }
6282             }
6283             else if (svix < svmax)
6284                 sv_setuv(svargs[svix++], (UV)i);
6285             continue;   /* not "break" */
6286
6287             /* UNKNOWN */
6288
6289         default:
6290       unknown:
6291             vectorize = FALSE;
6292             if (!args && ckWARN(WARN_PRINTF) &&
6293                   (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6294                 SV *msg = sv_newmortal();
6295                 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6296                           (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6297                 if (c) {
6298                     if (isPRINT(c))
6299                         Perl_sv_catpvf(aTHX_ msg,
6300                                        "\"%%%c\"", c & 0xFF);
6301                     else
6302                         Perl_sv_catpvf(aTHX_ msg,
6303                                        "\"%%\\%03"UVof"\"",
6304                                        (UV)c & 0xFF);
6305                 } else
6306                     sv_catpv(msg, "end of string");
6307                 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6308             }
6309
6310             /* output mangled stuff ... */
6311             if (c == '\0')
6312                 --q;
6313             eptr = p;
6314             elen = q - p;
6315
6316             /* ... right here, because formatting flags should not apply */
6317             SvGROW(sv, SvCUR(sv) + elen + 1);
6318             p = SvEND(sv);
6319             memcpy(p, eptr, elen);
6320             p += elen;
6321             *p = '\0';
6322             SvCUR(sv) = p - SvPVX(sv);
6323             continue;   /* not "break" */
6324         }
6325
6326         have = esignlen + zeros + elen;
6327         need = (have > width ? have : width);
6328         gap = need - have;
6329
6330         SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6331         p = SvEND(sv);
6332         if (esignlen && fill == '0') {
6333             for (i = 0; i < esignlen; i++)
6334                 *p++ = esignbuf[i];
6335         }
6336         if (gap && !left) {
6337             memset(p, fill, gap);
6338             p += gap;
6339         }
6340         if (esignlen && fill != '0') {
6341             for (i = 0; i < esignlen; i++)
6342                 *p++ = esignbuf[i];
6343         }
6344         if (zeros) {
6345             for (i = zeros; i; i--)
6346                 *p++ = '0';
6347         }
6348         if (elen) {
6349             memcpy(p, eptr, elen);
6350             p += elen;
6351         }
6352         if (gap && left) {
6353             memset(p, ' ', gap);
6354             p += gap;
6355         }
6356         if (vectorize) {
6357             if (veclen) {
6358                 memcpy(p, dotstr, dotstrlen);
6359                 p += dotstrlen;
6360             }
6361             else
6362                 vectorize = FALSE;              /* done iterating over vecstr */
6363         }
6364         if (is_utf)
6365             SvUTF8_on(sv);
6366         *p = '\0';
6367         SvCUR(sv) = p - SvPVX(sv);
6368         if (vectorize) {
6369             esignlen = 0;
6370             goto vector;
6371         }
6372     }
6373 }
6374
6375 #if defined(USE_ITHREADS)
6376
6377 #if defined(USE_THREADS)
6378 #  include "error: USE_THREADS and USE_ITHREADS are incompatible"
6379 #endif
6380
6381 #ifndef OpREFCNT_inc
6382 #  define OpREFCNT_inc(o)       ((o) ? (++(o)->op_targ, (o)) : Nullop)
6383 #endif
6384
6385 #ifndef GpREFCNT_inc
6386 #  define GpREFCNT_inc(gp)      ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6387 #endif
6388
6389
6390 #define sv_dup_inc(s)   SvREFCNT_inc(sv_dup(s))
6391 #define av_dup(s)       (AV*)sv_dup((SV*)s)
6392 #define av_dup_inc(s)   (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6393 #define hv_dup(s)       (HV*)sv_dup((SV*)s)
6394 #define hv_dup_inc(s)   (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6395 #define cv_dup(s)       (CV*)sv_dup((SV*)s)
6396 #define cv_dup_inc(s)   (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6397 #define io_dup(s)       (IO*)sv_dup((SV*)s)
6398 #define io_dup_inc(s)   (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6399 #define gv_dup(s)       (GV*)sv_dup((SV*)s)
6400 #define gv_dup_inc(s)   (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6401 #define SAVEPV(p)       (p ? savepv(p) : Nullch)
6402 #define SAVEPVN(p,n)    (p ? savepvn(p,n) : Nullch)
6403
6404 REGEXP *
6405 Perl_re_dup(pTHX_ REGEXP *r)
6406 {
6407     /* XXX fix when pmop->op_pmregexp becomes shared */
6408     return ReREFCNT_inc(r);
6409 }
6410
6411 PerlIO *
6412 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6413 {
6414     PerlIO *ret;
6415     if (!fp)
6416         return (PerlIO*)NULL;
6417
6418     /* look for it in the table first */
6419     ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6420     if (ret)
6421         return ret;
6422
6423     /* create anew and remember what it is */
6424     ret = PerlIO_fdupopen(fp);
6425     ptr_table_store(PL_ptr_table, fp, ret);
6426     return ret;
6427 }
6428
6429 DIR *
6430 Perl_dirp_dup(pTHX_ DIR *dp)
6431 {
6432     if (!dp)
6433         return (DIR*)NULL;
6434     /* XXX TODO */
6435     return dp;
6436 }
6437
6438 GP *
6439 Perl_gp_dup(pTHX_ GP *gp)
6440 {
6441     GP *ret;
6442     if (!gp)
6443         return (GP*)NULL;
6444     /* look for it in the table first */
6445     ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6446     if (ret)
6447         return ret;
6448
6449     /* create anew and remember what it is */
6450     Newz(0, ret, 1, GP);
6451     ptr_table_store(PL_ptr_table, gp, ret);
6452
6453     /* clone */
6454     ret->gp_refcnt      = 0;                    /* must be before any other dups! */
6455     ret->gp_sv          = sv_dup_inc(gp->gp_sv);
6456     ret->gp_io          = io_dup_inc(gp->gp_io);
6457     ret->gp_form        = cv_dup_inc(gp->gp_form);
6458     ret->gp_av          = av_dup_inc(gp->gp_av);
6459     ret->gp_hv          = hv_dup_inc(gp->gp_hv);
6460     ret->gp_egv         = gv_dup(gp->gp_egv);   /* GvEGV is not refcounted */
6461     ret->gp_cv          = cv_dup_inc(gp->gp_cv);
6462     ret->gp_cvgen       = gp->gp_cvgen;
6463     ret->gp_flags       = gp->gp_flags;
6464     ret->gp_line        = gp->gp_line;
6465     ret->gp_file        = gp->gp_file;          /* points to COP.cop_file */
6466     return ret;
6467 }
6468
6469 MAGIC *
6470 Perl_mg_dup(pTHX_ MAGIC *mg)
6471 {
6472     MAGIC *mgret = (MAGIC*)NULL;
6473     MAGIC *mgprev;
6474     if (!mg)
6475         return (MAGIC*)NULL;
6476     /* look for it in the table first */
6477     mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6478     if (mgret)
6479         return mgret;
6480
6481     for (; mg; mg = mg->mg_moremagic) {
6482         MAGIC *nmg;
6483         Newz(0, nmg, 1, MAGIC);
6484         if (!mgret)
6485             mgret = nmg;
6486         else
6487             mgprev->mg_moremagic = nmg;
6488         nmg->mg_virtual = mg->mg_virtual;       /* XXX copy dynamic vtable? */
6489         nmg->mg_private = mg->mg_private;
6490         nmg->mg_type    = mg->mg_type;
6491         nmg->mg_flags   = mg->mg_flags;
6492         if (mg->mg_type == 'r') {
6493             nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6494         }
6495         else {
6496             nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6497                               ? sv_dup_inc(mg->mg_obj)
6498                               : sv_dup(mg->mg_obj);
6499         }
6500         nmg->mg_len     = mg->mg_len;
6501         nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
6502         if (mg->mg_ptr && mg->mg_type != 'g') {
6503             if (mg->mg_len >= 0) {
6504                 nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
6505                 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6506                     AMT *amtp = (AMT*)mg->mg_ptr;
6507                     AMT *namtp = (AMT*)nmg->mg_ptr;
6508                     I32 i;
6509                     for (i = 1; i < NofAMmeth; i++) {
6510                         namtp->table[i] = cv_dup_inc(amtp->table[i]);
6511                     }
6512                 }
6513             }
6514             else if (mg->mg_len == HEf_SVKEY)
6515                 nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6516         }
6517         mgprev = nmg;
6518     }
6519     return mgret;
6520 }
6521
6522 PTR_TBL_t *
6523 Perl_ptr_table_new(pTHX)
6524 {
6525     PTR_TBL_t *tbl;
6526     Newz(0, tbl, 1, PTR_TBL_t);
6527     tbl->tbl_max        = 511;
6528     tbl->tbl_items      = 0;
6529     Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6530     return tbl;
6531 }
6532
6533 void *
6534 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6535 {
6536     PTR_TBL_ENT_t *tblent;
6537     UV hash = PTR2UV(sv);
6538     assert(tbl);
6539     tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6540     for (; tblent; tblent = tblent->next) {
6541         if (tblent->oldval == sv)
6542             return tblent->newval;
6543     }
6544     return (void*)NULL;
6545 }
6546
6547 void
6548 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6549 {
6550     PTR_TBL_ENT_t *tblent, **otblent;
6551     /* XXX this may be pessimal on platforms where pointers aren't good
6552      * hash values e.g. if they grow faster in the most significant
6553      * bits */
6554     UV hash = PTR2UV(oldv);
6555     bool i = 1;
6556
6557     assert(tbl);
6558     otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6559     for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6560         if (tblent->oldval == oldv) {
6561             tblent->newval = newv;
6562             tbl->tbl_items++;
6563             return;
6564         }
6565     }
6566     Newz(0, tblent, 1, PTR_TBL_ENT_t);
6567     tblent->oldval = oldv;
6568     tblent->newval = newv;
6569     tblent->next = *otblent;
6570     *otblent = tblent;
6571     tbl->tbl_items++;
6572     if (i && tbl->tbl_items > tbl->tbl_max)
6573         ptr_table_split(tbl);
6574 }
6575
6576 void
6577 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6578 {
6579     PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6580     UV oldsize = tbl->tbl_max + 1;
6581     UV newsize = oldsize * 2;
6582     UV i;
6583
6584     Renew(ary, newsize, PTR_TBL_ENT_t*);
6585     Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6586     tbl->tbl_max = --newsize;
6587     tbl->tbl_ary = ary;
6588     for (i=0; i < oldsize; i++, ary++) {
6589         PTR_TBL_ENT_t **curentp, **entp, *ent;
6590         if (!*ary)
6591             continue;
6592         curentp = ary + oldsize;
6593         for (entp = ary, ent = *ary; ent; ent = *entp) {
6594             if ((newsize & PTR2UV(ent->oldval)) != i) {
6595                 *entp = ent->next;
6596                 ent->next = *curentp;
6597                 *curentp = ent;
6598                 continue;
6599             }
6600             else
6601                 entp = &ent->next;
6602         }
6603     }
6604 }
6605
6606 #ifdef DEBUGGING
6607 char *PL_watch_pvx;
6608 #endif
6609
6610 SV *
6611 Perl_sv_dup(pTHX_ SV *sstr)
6612 {
6613     U32 sflags;
6614     int dtype;
6615     int stype;
6616     SV *dstr;
6617
6618     if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6619         return Nullsv;
6620     /* look for it in the table first */
6621     dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6622     if (dstr)
6623         return dstr;
6624
6625     /* create anew and remember what it is */
6626     new_SV(dstr);
6627     ptr_table_store(PL_ptr_table, sstr, dstr);
6628
6629     /* clone */
6630     SvFLAGS(dstr)       = SvFLAGS(sstr);
6631     SvFLAGS(dstr)       &= ~SVf_OOK;            /* don't propagate OOK hack */
6632     SvREFCNT(dstr)      = 0;                    /* must be before any other dups! */
6633
6634 #ifdef DEBUGGING
6635     if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6636         PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6637                       PL_watch_pvx, SvPVX(sstr));
6638 #endif
6639
6640     switch (SvTYPE(sstr)) {
6641     case SVt_NULL:
6642         SvANY(dstr)     = NULL;
6643         break;
6644     case SVt_IV:
6645         SvANY(dstr)     = new_XIV();
6646         SvIVX(dstr)     = SvIVX(sstr);
6647         break;
6648     case SVt_NV:
6649         SvANY(dstr)     = new_XNV();
6650         SvNVX(dstr)     = SvNVX(sstr);
6651         break;
6652     case SVt_RV:
6653         SvANY(dstr)     = new_XRV();
6654         SvRV(dstr)      = sv_dup_inc(SvRV(sstr));
6655         break;
6656     case SVt_PV:
6657         SvANY(dstr)     = new_XPV();
6658         SvCUR(dstr)     = SvCUR(sstr);
6659         SvLEN(dstr)     = SvLEN(sstr);
6660         if (SvROK(sstr))
6661             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6662         else if (SvPVX(sstr) && SvLEN(sstr))
6663             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6664         else
6665             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6666         break;
6667     case SVt_PVIV:
6668         SvANY(dstr)     = new_XPVIV();
6669         SvCUR(dstr)     = SvCUR(sstr);
6670         SvLEN(dstr)     = SvLEN(sstr);
6671         SvIVX(dstr)     = SvIVX(sstr);
6672         if (SvROK(sstr))
6673             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6674         else if (SvPVX(sstr) && SvLEN(sstr))
6675             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6676         else
6677             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6678         break;
6679     case SVt_PVNV:
6680         SvANY(dstr)     = new_XPVNV();
6681         SvCUR(dstr)     = SvCUR(sstr);
6682         SvLEN(dstr)     = SvLEN(sstr);
6683         SvIVX(dstr)     = SvIVX(sstr);
6684         SvNVX(dstr)     = SvNVX(sstr);
6685         if (SvROK(sstr))
6686             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6687         else if (SvPVX(sstr) && SvLEN(sstr))
6688             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6689         else
6690             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6691         break;
6692     case SVt_PVMG:
6693         SvANY(dstr)     = new_XPVMG();
6694         SvCUR(dstr)     = SvCUR(sstr);
6695         SvLEN(dstr)     = SvLEN(sstr);
6696         SvIVX(dstr)     = SvIVX(sstr);
6697         SvNVX(dstr)     = SvNVX(sstr);
6698         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6699         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6700         if (SvROK(sstr))
6701             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6702         else if (SvPVX(sstr) && SvLEN(sstr))
6703             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6704         else
6705             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6706         break;
6707     case SVt_PVBM:
6708         SvANY(dstr)     = new_XPVBM();
6709         SvCUR(dstr)     = SvCUR(sstr);
6710         SvLEN(dstr)     = SvLEN(sstr);
6711         SvIVX(dstr)     = SvIVX(sstr);
6712         SvNVX(dstr)     = SvNVX(sstr);
6713         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6714         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6715         if (SvROK(sstr))
6716             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6717         else if (SvPVX(sstr) && SvLEN(sstr))
6718             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6719         else
6720             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6721         BmRARE(dstr)    = BmRARE(sstr);
6722         BmUSEFUL(dstr)  = BmUSEFUL(sstr);
6723         BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6724         break;
6725     case SVt_PVLV:
6726         SvANY(dstr)     = new_XPVLV();
6727         SvCUR(dstr)     = SvCUR(sstr);
6728         SvLEN(dstr)     = SvLEN(sstr);
6729         SvIVX(dstr)     = SvIVX(sstr);
6730         SvNVX(dstr)     = SvNVX(sstr);
6731         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6732         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6733         if (SvROK(sstr))
6734             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6735         else if (SvPVX(sstr) && SvLEN(sstr))
6736             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6737         else
6738             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6739         LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
6740         LvTARGLEN(dstr) = LvTARGLEN(sstr);
6741         LvTARG(dstr)    = sv_dup_inc(LvTARG(sstr));
6742         LvTYPE(dstr)    = LvTYPE(sstr);
6743         break;
6744     case SVt_PVGV:
6745         SvANY(dstr)     = new_XPVGV();
6746         SvCUR(dstr)     = SvCUR(sstr);
6747         SvLEN(dstr)     = SvLEN(sstr);
6748         SvIVX(dstr)     = SvIVX(sstr);
6749         SvNVX(dstr)     = SvNVX(sstr);
6750         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6751         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6752         if (SvROK(sstr))
6753             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6754         else if (SvPVX(sstr) && SvLEN(sstr))
6755             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6756         else
6757             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6758         GvNAMELEN(dstr) = GvNAMELEN(sstr);
6759         GvNAME(dstr)    = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6760         GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
6761         GvFLAGS(dstr)   = GvFLAGS(sstr);
6762         GvGP(dstr)      = gp_dup(GvGP(sstr));
6763         (void)GpREFCNT_inc(GvGP(dstr));
6764         break;
6765     case SVt_PVIO:
6766         SvANY(dstr)     = new_XPVIO();
6767         SvCUR(dstr)     = SvCUR(sstr);
6768         SvLEN(dstr)     = SvLEN(sstr);
6769         SvIVX(dstr)     = SvIVX(sstr);
6770         SvNVX(dstr)     = SvNVX(sstr);
6771         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6772         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6773         if (SvROK(sstr))
6774             SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
6775         else if (SvPVX(sstr) && SvLEN(sstr))
6776             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6777         else
6778             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6779         IoIFP(dstr)     = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6780         if (IoOFP(sstr) == IoIFP(sstr))
6781             IoOFP(dstr) = IoIFP(dstr);
6782         else
6783             IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6784         /* PL_rsfp_filters entries have fake IoDIRP() */
6785         if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6786             IoDIRP(dstr)        = dirp_dup(IoDIRP(sstr));
6787         else
6788             IoDIRP(dstr)        = IoDIRP(sstr);
6789         IoLINES(dstr)           = IoLINES(sstr);
6790         IoPAGE(dstr)            = IoPAGE(sstr);
6791         IoPAGE_LEN(dstr)        = IoPAGE_LEN(sstr);
6792         IoLINES_LEFT(dstr)      = IoLINES_LEFT(sstr);
6793         IoTOP_NAME(dstr)        = SAVEPV(IoTOP_NAME(sstr));
6794         IoTOP_GV(dstr)          = gv_dup(IoTOP_GV(sstr));
6795         IoFMT_NAME(dstr)        = SAVEPV(IoFMT_NAME(sstr));
6796         IoFMT_GV(dstr)          = gv_dup(IoFMT_GV(sstr));
6797         IoBOTTOM_NAME(dstr)     = SAVEPV(IoBOTTOM_NAME(sstr));
6798         IoBOTTOM_GV(dstr)       = gv_dup(IoBOTTOM_GV(sstr));
6799         IoSUBPROCESS(dstr)      = IoSUBPROCESS(sstr);
6800         IoTYPE(dstr)            = IoTYPE(sstr);
6801         IoFLAGS(dstr)           = IoFLAGS(sstr);
6802         break;
6803     case SVt_PVAV:
6804         SvANY(dstr)     = new_XPVAV();
6805         SvCUR(dstr)     = SvCUR(sstr);
6806         SvLEN(dstr)     = SvLEN(sstr);
6807         SvIVX(dstr)     = SvIVX(sstr);
6808         SvNVX(dstr)     = SvNVX(sstr);
6809         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6810         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6811         AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6812         AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6813         if (AvARRAY((AV*)sstr)) {
6814             SV **dst_ary, **src_ary;
6815             SSize_t items = AvFILLp((AV*)sstr) + 1;
6816
6817             src_ary = AvARRAY((AV*)sstr);
6818             Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6819             ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6820             SvPVX(dstr) = (char*)dst_ary;
6821             AvALLOC((AV*)dstr) = dst_ary;
6822             if (AvREAL((AV*)sstr)) {
6823                 while (items-- > 0)
6824                     *dst_ary++ = sv_dup_inc(*src_ary++);
6825             }
6826             else {
6827                 while (items-- > 0)
6828                     *dst_ary++ = sv_dup(*src_ary++);
6829             }
6830             items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6831             while (items-- > 0) {
6832                 *dst_ary++ = &PL_sv_undef;
6833             }
6834         }
6835         else {
6836             SvPVX(dstr)         = Nullch;
6837             AvALLOC((AV*)dstr)  = (SV**)NULL;
6838         }
6839         break;
6840     case SVt_PVHV:
6841         SvANY(dstr)     = new_XPVHV();
6842         SvCUR(dstr)     = SvCUR(sstr);
6843         SvLEN(dstr)     = SvLEN(sstr);
6844         SvIVX(dstr)     = SvIVX(sstr);
6845         SvNVX(dstr)     = SvNVX(sstr);
6846         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6847         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6848         HvRITER((HV*)dstr)      = HvRITER((HV*)sstr);
6849         if (HvARRAY((HV*)sstr)) {
6850             HE *entry;
6851             STRLEN i = 0;
6852             XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6853             XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6854             Newz(0, dxhv->xhv_array,
6855                  PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6856             while (i <= sxhv->xhv_max) {
6857                 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6858                                                     !!HvSHAREKEYS(sstr));
6859                 ++i;
6860             }
6861             dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6862         }
6863         else {
6864             SvPVX(dstr)         = Nullch;
6865             HvEITER((HV*)dstr)  = (HE*)NULL;
6866         }
6867         HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
6868         HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
6869         break;
6870     case SVt_PVFM:
6871         SvANY(dstr)     = new_XPVFM();
6872         FmLINES(dstr)   = FmLINES(sstr);
6873         goto dup_pvcv;
6874         /* NOTREACHED */
6875     case SVt_PVCV:
6876         SvANY(dstr)     = new_XPVCV();
6877 dup_pvcv:
6878         SvCUR(dstr)     = SvCUR(sstr);
6879         SvLEN(dstr)     = SvLEN(sstr);
6880         SvIVX(dstr)     = SvIVX(sstr);
6881         SvNVX(dstr)     = SvNVX(sstr);
6882         SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
6883         SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
6884         if (SvPVX(sstr) && SvLEN(sstr))
6885             SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6886         else
6887             SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
6888         CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6889         CvSTART(dstr)   = CvSTART(sstr);
6890         CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
6891         CvXSUB(dstr)    = CvXSUB(sstr);
6892         CvXSUBANY(dstr) = CvXSUBANY(sstr);
6893         CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
6894         CvDEPTH(dstr)   = CvDEPTH(sstr);
6895         if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6896             /* XXX padlists are real, but pretend to be not */
6897             AvREAL_on(CvPADLIST(sstr));
6898             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6899             AvREAL_off(CvPADLIST(sstr));
6900             AvREAL_off(CvPADLIST(dstr));
6901         }
6902         else
6903             CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
6904         CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6905         CvFLAGS(dstr)   = CvFLAGS(sstr);
6906         break;
6907     default:
6908         Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6909         break;
6910     }
6911
6912     if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6913         ++PL_sv_objcount;
6914
6915     return dstr;
6916 }
6917
6918 PERL_CONTEXT *
6919 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6920 {
6921     PERL_CONTEXT *ncxs;
6922
6923     if (!cxs)
6924         return (PERL_CONTEXT*)NULL;
6925
6926     /* look for it in the table first */
6927     ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6928     if (ncxs)
6929         return ncxs;
6930
6931     /* create anew and remember what it is */
6932     Newz(56, ncxs, max + 1, PERL_CONTEXT);
6933     ptr_table_store(PL_ptr_table, cxs, ncxs);
6934
6935     while (ix >= 0) {
6936         PERL_CONTEXT *cx = &cxs[ix];
6937         PERL_CONTEXT *ncx = &ncxs[ix];
6938         ncx->cx_type    = cx->cx_type;
6939         if (CxTYPE(cx) == CXt_SUBST) {
6940             Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6941         }
6942         else {
6943             ncx->blk_oldsp      = cx->blk_oldsp;
6944             ncx->blk_oldcop     = cx->blk_oldcop;
6945             ncx->blk_oldretsp   = cx->blk_oldretsp;
6946             ncx->blk_oldmarksp  = cx->blk_oldmarksp;
6947             ncx->blk_oldscopesp = cx->blk_oldscopesp;
6948             ncx->blk_oldpm      = cx->blk_oldpm;
6949             ncx->blk_gimme      = cx->blk_gimme;
6950             switch (CxTYPE(cx)) {
6951             case CXt_SUB:
6952                 ncx->blk_sub.cv         = (cx->blk_sub.olddepth == 0
6953                                            ? cv_dup_inc(cx->blk_sub.cv)
6954                                            : cv_dup(cx->blk_sub.cv));
6955                 ncx->blk_sub.argarray   = (cx->blk_sub.hasargs
6956                                            ? av_dup_inc(cx->blk_sub.argarray)
6957                                            : Nullav);
6958                 ncx->blk_sub.savearray  = av_dup(cx->blk_sub.savearray);
6959                 ncx->blk_sub.olddepth   = cx->blk_sub.olddepth;
6960                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
6961                 ncx->blk_sub.lval       = cx->blk_sub.lval;
6962                 break;
6963             case CXt_EVAL:
6964                 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6965                 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6966                 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
6967                 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6968                 ncx->blk_eval.cur_text  = sv_dup(cx->blk_eval.cur_text);
6969                 break;
6970             case CXt_LOOP:
6971                 ncx->blk_loop.label     = cx->blk_loop.label;
6972                 ncx->blk_loop.resetsp   = cx->blk_loop.resetsp;
6973                 ncx->blk_loop.redo_op   = cx->blk_loop.redo_op;
6974                 ncx->blk_loop.next_op   = cx->blk_loop.next_op;
6975                 ncx->blk_loop.last_op   = cx->blk_loop.last_op;
6976                 ncx->blk_loop.iterdata  = (CxPADLOOP(cx)
6977                                            ? cx->blk_loop.iterdata
6978                                            : gv_dup((GV*)cx->blk_loop.iterdata));
6979                 ncx->blk_loop.itersave  = sv_dup_inc(cx->blk_loop.itersave);
6980                 ncx->blk_loop.iterlval  = sv_dup_inc(cx->blk_loop.iterlval);
6981                 ncx->blk_loop.iterary   = av_dup_inc(cx->blk_loop.iterary);
6982                 ncx->blk_loop.iterix    = cx->blk_loop.iterix;
6983                 ncx->blk_loop.itermax   = cx->blk_loop.itermax;
6984                 break;
6985             case CXt_FORMAT:
6986                 ncx->blk_sub.cv         = cv_dup(cx->blk_sub.cv);
6987                 ncx->blk_sub.gv         = gv_dup(cx->blk_sub.gv);
6988                 ncx->blk_sub.dfoutgv    = gv_dup_inc(cx->blk_sub.dfoutgv);
6989                 ncx->blk_sub.hasargs    = cx->blk_sub.hasargs;
6990                 break;
6991             case CXt_BLOCK:
6992             case CXt_NULL:
6993                 break;
6994             }
6995         }
6996         --ix;
6997     }
6998     return ncxs;
6999 }
7000
7001 PERL_SI *
7002 Perl_si_dup(pTHX_ PERL_SI *si)
7003 {
7004     PERL_SI *nsi;
7005
7006     if (!si)
7007         return (PERL_SI*)NULL;
7008
7009     /* look for it in the table first */
7010     nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7011     if (nsi)
7012         return nsi;
7013
7014     /* create anew and remember what it is */
7015     Newz(56, nsi, 1, PERL_SI);
7016     ptr_table_store(PL_ptr_table, si, nsi);
7017
7018     nsi->si_stack       = av_dup_inc(si->si_stack);
7019     nsi->si_cxix        = si->si_cxix;
7020     nsi->si_cxmax       = si->si_cxmax;
7021     nsi->si_cxstack     = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7022     nsi->si_type        = si->si_type;
7023     nsi->si_prev        = si_dup(si->si_prev);
7024     nsi->si_next        = si_dup(si->si_next);
7025     nsi->si_markoff     = si->si_markoff;
7026
7027     return nsi;
7028 }
7029
7030 #define POPINT(ss,ix)   ((ss)[--(ix)].any_i32)
7031 #define TOPINT(ss,ix)   ((ss)[ix].any_i32)
7032 #define POPLONG(ss,ix)  ((ss)[--(ix)].any_long)
7033 #define TOPLONG(ss,ix)  ((ss)[ix].any_long)
7034 #define POPIV(ss,ix)    ((ss)[--(ix)].any_iv)
7035 #define TOPIV(ss,ix)    ((ss)[ix].any_iv)
7036 #define POPPTR(ss,ix)   ((ss)[--(ix)].any_ptr)
7037 #define TOPPTR(ss,ix)   ((ss)[ix].any_ptr)
7038 #define POPDPTR(ss,ix)  ((ss)[--(ix)].any_dptr)
7039 #define TOPDPTR(ss,ix)  ((ss)[ix].any_dptr)
7040 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7041 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7042
7043 /* XXXXX todo */
7044 #define pv_dup_inc(p)   SAVEPV(p)
7045 #define pv_dup(p)       SAVEPV(p)
7046 #define svp_dup_inc(p,pp)       any_dup(p,pp)
7047
7048 void *
7049 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7050 {
7051     void *ret;
7052
7053     if (!v)
7054         return (void*)NULL;
7055
7056     /* look for it in the table first */
7057     ret = ptr_table_fetch(PL_ptr_table, v);
7058     if (ret)
7059         return ret;
7060
7061     /* see if it is part of the interpreter structure */
7062     if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7063         ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7064     else
7065         ret = v;
7066
7067     return ret;
7068 }
7069
7070 ANY *
7071 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7072 {
7073     ANY *ss     = proto_perl->Tsavestack;
7074     I32 ix      = proto_perl->Tsavestack_ix;
7075     I32 max     = proto_perl->Tsavestack_max;
7076     ANY *nss;
7077     SV *sv;
7078     GV *gv;
7079     AV *av;
7080     HV *hv;
7081     void* ptr;
7082     int intval;
7083     long longval;
7084     GP *gp;
7085     IV iv;
7086     I32 i;
7087     char *c;
7088     void (*dptr) (void*);
7089     void (*dxptr) (pTHXo_ void*);
7090
7091     Newz(54, nss, max, ANY);
7092
7093     while (ix > 0) {
7094         i = POPINT(ss,ix);
7095         TOPINT(nss,ix) = i;
7096         switch (i) {
7097         case SAVEt_ITEM:                        /* normal string */
7098             sv = (SV*)POPPTR(ss,ix);
7099             TOPPTR(nss,ix) = sv_dup_inc(sv);
7100             sv = (SV*)POPPTR(ss,ix);
7101             TOPPTR(nss,ix) = sv_dup_inc(sv);
7102             break;
7103         case SAVEt_SV:                          /* scalar reference */
7104             sv = (SV*)POPPTR(ss,ix);
7105             TOPPTR(nss,ix) = sv_dup_inc(sv);
7106             gv = (GV*)POPPTR(ss,ix);
7107             TOPPTR(nss,ix) = gv_dup_inc(gv);
7108             break;
7109         case SAVEt_GENERIC_SVREF:               /* generic sv */
7110         case SAVEt_SVREF:                       /* scalar reference */
7111             sv = (SV*)POPPTR(ss,ix);
7112             TOPPTR(nss,ix) = sv_dup_inc(sv);
7113             ptr = POPPTR(ss,ix);
7114             TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7115             break;
7116         case SAVEt_AV:                          /* array reference */
7117             av = (AV*)POPPTR(ss,ix);
7118             TOPPTR(nss,ix) = av_dup_inc(av);
7119             gv = (GV*)POPPTR(ss,ix);
7120             TOPPTR(nss,ix) = gv_dup(gv);
7121             break;
7122         case SAVEt_HV:                          /* hash reference */
7123             hv = (HV*)POPPTR(ss,ix);
7124             TOPPTR(nss,ix) = hv_dup_inc(hv);
7125             gv = (GV*)POPPTR(ss,ix);
7126             TOPPTR(nss,ix) = gv_dup(gv);
7127             break;
7128         case SAVEt_INT:                         /* int reference */
7129             ptr = POPPTR(ss,ix);
7130             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7131             intval = (int)POPINT(ss,ix);
7132             TOPINT(nss,ix) = intval;
7133             break;
7134         case SAVEt_LONG:                        /* long reference */
7135             ptr = POPPTR(ss,ix);
7136             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7137             longval = (long)POPLONG(ss,ix);
7138             TOPLONG(nss,ix) = longval;
7139             break;
7140         case SAVEt_I32:                         /* I32 reference */
7141         case SAVEt_I16:                         /* I16 reference */
7142         case SAVEt_I8:                          /* I8 reference */
7143             ptr = POPPTR(ss,ix);
7144             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7145             i = POPINT(ss,ix);
7146             TOPINT(nss,ix) = i;
7147             break;
7148         case SAVEt_IV:                          /* IV reference */
7149             ptr = POPPTR(ss,ix);
7150             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7151             iv = POPIV(ss,ix);
7152             TOPIV(nss,ix) = iv;
7153             break;
7154         case SAVEt_SPTR:                        /* SV* reference */
7155             ptr = POPPTR(ss,ix);
7156             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7157             sv = (SV*)POPPTR(ss,ix);
7158             TOPPTR(nss,ix) = sv_dup(sv);
7159             break;
7160         case SAVEt_VPTR:                        /* random* reference */
7161             ptr = POPPTR(ss,ix);
7162             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7163             ptr = POPPTR(ss,ix);
7164             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7165             break;
7166         case SAVEt_PPTR:                        /* char* reference */
7167             ptr = POPPTR(ss,ix);
7168             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7169             c = (char*)POPPTR(ss,ix);
7170             TOPPTR(nss,ix) = pv_dup(c);
7171             break;
7172         case SAVEt_HPTR:                        /* HV* reference */
7173             ptr = POPPTR(ss,ix);
7174             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7175             hv = (HV*)POPPTR(ss,ix);
7176             TOPPTR(nss,ix) = hv_dup(hv);
7177             break;
7178         case SAVEt_APTR:                        /* AV* reference */
7179             ptr = POPPTR(ss,ix);
7180             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7181             av = (AV*)POPPTR(ss,ix);
7182             TOPPTR(nss,ix) = av_dup(av);
7183             break;
7184         case SAVEt_NSTAB:
7185             gv = (GV*)POPPTR(ss,ix);
7186             TOPPTR(nss,ix) = gv_dup(gv);
7187             break;
7188         case SAVEt_GP:                          /* scalar reference */
7189             gp = (GP*)POPPTR(ss,ix);
7190             TOPPTR(nss,ix) = gp = gp_dup(gp);
7191             (void)GpREFCNT_inc(gp);
7192             gv = (GV*)POPPTR(ss,ix);
7193             TOPPTR(nss,ix) = gv_dup_inc(c);
7194             c = (char*)POPPTR(ss,ix);
7195             TOPPTR(nss,ix) = pv_dup(c);
7196             iv = POPIV(ss,ix);
7197             TOPIV(nss,ix) = iv;
7198             iv = POPIV(ss,ix);
7199             TOPIV(nss,ix) = iv;
7200             break;
7201         case SAVEt_FREESV:
7202             sv = (SV*)POPPTR(ss,ix);
7203             TOPPTR(nss,ix) = sv_dup_inc(sv);
7204             break;
7205         case SAVEt_FREEOP:
7206             ptr = POPPTR(ss,ix);
7207             if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7208                 /* these are assumed to be refcounted properly */
7209                 switch (((OP*)ptr)->op_type) {
7210                 case OP_LEAVESUB:
7211                 case OP_LEAVESUBLV:
7212                 case OP_LEAVEEVAL:
7213                 case OP_LEAVE:
7214                 case OP_SCOPE:
7215                 case OP_LEAVEWRITE:
7216                     TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7217                     break;
7218                 default:
7219                     TOPPTR(nss,ix) = Nullop;
7220                     break;
7221                 }
7222             }
7223             else
7224                 TOPPTR(nss,ix) = Nullop;
7225             break;
7226         case SAVEt_FREEPV:
7227             c = (char*)POPPTR(ss,ix);
7228             TOPPTR(nss,ix) = pv_dup_inc(c);
7229             break;
7230         case SAVEt_CLEARSV:
7231             longval = POPLONG(ss,ix);
7232             TOPLONG(nss,ix) = longval;
7233             break;
7234         case SAVEt_DELETE:
7235             hv = (HV*)POPPTR(ss,ix);
7236             TOPPTR(nss,ix) = hv_dup_inc(hv);
7237             c = (char*)POPPTR(ss,ix);
7238             TOPPTR(nss,ix) = pv_dup_inc(c);
7239             i = POPINT(ss,ix);
7240             TOPINT(nss,ix) = i;
7241             break;
7242         case SAVEt_DESTRUCTOR:
7243             ptr = POPPTR(ss,ix);
7244             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
7245             dptr = POPDPTR(ss,ix);
7246             TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7247             break;
7248         case SAVEt_DESTRUCTOR_X:
7249             ptr = POPPTR(ss,ix);
7250             TOPPTR(nss,ix) = any_dup(ptr, proto_perl);  /* XXX quite arbitrary */
7251             dxptr = POPDXPTR(ss,ix);
7252             TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7253             break;
7254         case SAVEt_REGCONTEXT:
7255         case SAVEt_ALLOC:
7256             i = POPINT(ss,ix);
7257             TOPINT(nss,ix) = i;
7258             ix -= i;
7259             break;
7260         case SAVEt_STACK_POS:           /* Position on Perl stack */
7261             i = POPINT(ss,ix);
7262             TOPINT(nss,ix) = i;
7263             break;
7264         case SAVEt_AELEM:               /* array element */
7265             sv = (SV*)POPPTR(ss,ix);
7266             TOPPTR(nss,ix) = sv_dup_inc(sv);
7267             i = POPINT(ss,ix);
7268             TOPINT(nss,ix) = i;
7269             av = (AV*)POPPTR(ss,ix);
7270             TOPPTR(nss,ix) = av_dup_inc(av);
7271             break;
7272         case SAVEt_HELEM:               /* hash element */
7273             sv = (SV*)POPPTR(ss,ix);
7274             TOPPTR(nss,ix) = sv_dup_inc(sv);
7275             sv = (SV*)POPPTR(ss,ix);
7276             TOPPTR(nss,ix) = sv_dup_inc(sv);
7277             hv = (HV*)POPPTR(ss,ix);
7278             TOPPTR(nss,ix) = hv_dup_inc(hv);
7279             break;
7280         case SAVEt_OP:
7281             ptr = POPPTR(ss,ix);
7282             TOPPTR(nss,ix) = ptr;
7283             break;
7284         case SAVEt_HINTS:
7285             i = POPINT(ss,ix);
7286             TOPINT(nss,ix) = i;
7287             break;
7288         case SAVEt_COMPPAD:
7289             av = (AV*)POPPTR(ss,ix);
7290             TOPPTR(nss,ix) = av_dup(av);
7291             break;
7292         default:
7293             Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7294         }
7295     }
7296
7297     return nss;
7298 }
7299
7300 #ifdef PERL_OBJECT
7301 #include "XSUB.h"
7302 #endif
7303
7304 PerlInterpreter *
7305 perl_clone(PerlInterpreter *proto_perl, UV flags)
7306 {
7307 #ifdef PERL_OBJECT
7308     CPerlObj *pPerl = (CPerlObj*)proto_perl;
7309 #endif
7310
7311 #ifdef PERL_IMPLICIT_SYS
7312     return perl_clone_using(proto_perl, flags,
7313                             proto_perl->IMem,
7314                             proto_perl->IMemShared,
7315                             proto_perl->IMemParse,
7316                             proto_perl->IEnv,
7317                             proto_perl->IStdIO,
7318                             proto_perl->ILIO,
7319                             proto_perl->IDir,
7320                             proto_perl->ISock,
7321                             proto_perl->IProc);
7322 }
7323
7324 PerlInterpreter *
7325 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7326                  struct IPerlMem* ipM, struct IPerlMem* ipMS,
7327                  struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7328                  struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7329                  struct IPerlDir* ipD, struct IPerlSock* ipS,
7330                  struct IPerlProc* ipP)
7331 {
7332     /* XXX many of the string copies here can be optimized if they're
7333      * constants; they need to be allocated as common memory and just
7334      * their pointers copied. */
7335
7336     IV i;
7337     SV *sv;
7338     SV **svp;
7339 #  ifdef PERL_OBJECT
7340     CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7341                                         ipD, ipS, ipP);
7342     PERL_SET_THX(pPerl);
7343 #  else         /* !PERL_OBJECT */
7344     PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7345     PERL_SET_THX(my_perl);
7346
7347 #    ifdef DEBUGGING
7348     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7349     PL_markstack = 0;
7350     PL_scopestack = 0;
7351     PL_savestack = 0;
7352     PL_retstack = 0;
7353 #    else       /* !DEBUGGING */
7354     Zero(my_perl, 1, PerlInterpreter);
7355 #    endif      /* DEBUGGING */
7356
7357     /* host pointers */
7358     PL_Mem              = ipM;
7359     PL_MemShared        = ipMS;
7360     PL_MemParse         = ipMP;
7361     PL_Env              = ipE;
7362     PL_StdIO            = ipStd;
7363     PL_LIO              = ipLIO;
7364     PL_Dir              = ipD;
7365     PL_Sock             = ipS;
7366     PL_Proc             = ipP;
7367 #  endif        /* PERL_OBJECT */
7368 #else           /* !PERL_IMPLICIT_SYS */
7369     IV i;
7370     SV *sv;
7371     SV **svp;
7372     PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7373     PERL_SET_THX(my_perl);
7374
7375 #    ifdef DEBUGGING
7376     memset(my_perl, 0xab, sizeof(PerlInterpreter));
7377     PL_markstack = 0;
7378     PL_scopestack = 0;
7379     PL_savestack = 0;
7380     PL_retstack = 0;
7381 #    else       /* !DEBUGGING */
7382     Zero(my_perl, 1, PerlInterpreter);
7383 #    endif      /* DEBUGGING */
7384 #endif          /* PERL_IMPLICIT_SYS */
7385
7386     /* arena roots */
7387     PL_xiv_arenaroot    = NULL;
7388     PL_xiv_root         = NULL;
7389     PL_xnv_root         = NULL;
7390     PL_xrv_root         = NULL;
7391     PL_xpv_root         = NULL;
7392     PL_xpviv_root       = NULL;
7393     PL_xpvnv_root       = NULL;
7394     PL_xpvcv_root       = NULL;
7395     PL_xpvav_root       = NULL;
7396     PL_xpvhv_root       = NULL;
7397     PL_xpvmg_root       = NULL;
7398     PL_xpvlv_root       = NULL;
7399     PL_xpvbm_root       = NULL;
7400     PL_he_root          = NULL;
7401     PL_nice_chunk       = NULL;
7402     PL_nice_chunk_size  = 0;
7403     PL_sv_count         = 0;
7404     PL_sv_objcount      = 0;
7405     PL_sv_root          = Nullsv;
7406     PL_sv_arenaroot     = Nullsv;
7407
7408     PL_debug            = proto_perl->Idebug;
7409
7410     /* create SV map for pointer relocation */
7411     PL_ptr_table = ptr_table_new();
7412
7413     /* initialize these special pointers as early as possible */
7414     SvANY(&PL_sv_undef)         = NULL;
7415     SvREFCNT(&PL_sv_undef)      = (~(U32)0)/2;
7416     SvFLAGS(&PL_sv_undef)       = SVf_READONLY|SVt_NULL;
7417     ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7418
7419 #ifdef PERL_OBJECT
7420     SvUPGRADE(&PL_sv_no, SVt_PVNV);
7421 #else
7422     SvANY(&PL_sv_no)            = new_XPVNV();
7423 #endif
7424     SvREFCNT(&PL_sv_no)         = (~(U32)0)/2;
7425     SvFLAGS(&PL_sv_no)          = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7426     SvPVX(&PL_sv_no)            = SAVEPVN(PL_No, 0);
7427     SvCUR(&PL_sv_no)            = 0;
7428     SvLEN(&PL_sv_no)            = 1;
7429     SvNVX(&PL_sv_no)            = 0;
7430     ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7431
7432 #ifdef PERL_OBJECT
7433     SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7434 #else
7435     SvANY(&PL_sv_yes)           = new_XPVNV();
7436 #endif
7437     SvREFCNT(&PL_sv_yes)        = (~(U32)0)/2;
7438     SvFLAGS(&PL_sv_yes)         = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7439     SvPVX(&PL_sv_yes)           = SAVEPVN(PL_Yes, 1);
7440     SvCUR(&PL_sv_yes)           = 1;
7441     SvLEN(&PL_sv_yes)           = 2;
7442     SvNVX(&PL_sv_yes)           = 1;
7443     ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7444
7445     /* create shared string table */
7446     PL_strtab           = newHV();
7447     HvSHAREKEYS_off(PL_strtab);
7448     hv_ksplit(PL_strtab, 512);
7449     ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7450
7451     PL_compiling                = proto_perl->Icompiling;
7452     PL_compiling.cop_stashpv    = SAVEPV(PL_compiling.cop_stashpv);
7453     PL_compiling.cop_file       = SAVEPV(PL_compiling.cop_file);
7454     ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7455     if (!specialWARN(PL_compiling.cop_warnings))
7456         PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7457     PL_curcop           = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7458
7459     /* pseudo environmental stuff */
7460     PL_origargc         = proto_perl->Iorigargc;
7461     i = PL_origargc;
7462     New(0, PL_origargv, i+1, char*);
7463     PL_origargv[i] = '\0';
7464     while (i-- > 0) {
7465         PL_origargv[i]  = SAVEPV(proto_perl->Iorigargv[i]);
7466     }
7467     PL_envgv            = gv_dup(proto_perl->Ienvgv);
7468     PL_incgv            = gv_dup(proto_perl->Iincgv);
7469     PL_hintgv           = gv_dup(proto_perl->Ihintgv);
7470     PL_origfilename     = SAVEPV(proto_perl->Iorigfilename);
7471     PL_diehook          = sv_dup_inc(proto_perl->Idiehook);
7472     PL_warnhook         = sv_dup_inc(proto_perl->Iwarnhook);
7473
7474     /* switches */
7475     PL_minus_c          = proto_perl->Iminus_c;
7476     PL_patchlevel       = sv_dup_inc(proto_perl->Ipatchlevel);
7477     PL_localpatches     = proto_perl->Ilocalpatches;
7478     PL_splitstr         = proto_perl->Isplitstr;
7479     PL_preprocess       = proto_perl->Ipreprocess;
7480     PL_minus_n          = proto_perl->Iminus_n;
7481     PL_minus_p          = proto_perl->Iminus_p;
7482     PL_minus_l          = proto_perl->Iminus_l;
7483     PL_minus_a          = proto_perl->Iminus_a;
7484     PL_minus_F          = proto_perl->Iminus_F;
7485     PL_doswitches       = proto_perl->Idoswitches;
7486     PL_dowarn           = proto_perl->Idowarn;
7487     PL_doextract        = proto_perl->Idoextract;
7488     PL_sawampersand     = proto_perl->Isawampersand;
7489     PL_unsafe           = proto_perl->Iunsafe;
7490     PL_inplace          = SAVEPV(proto_perl->Iinplace);
7491     PL_e_script         = sv_dup_inc(proto_perl->Ie_script);
7492     PL_perldb           = proto_perl->Iperldb;
7493     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7494
7495     /* magical thingies */
7496     /* XXX time(&PL_basetime) when asked for? */
7497     PL_basetime         = proto_perl->Ibasetime;
7498     PL_formfeed         = sv_dup(proto_perl->Iformfeed);
7499
7500     PL_maxsysfd         = proto_perl->Imaxsysfd;
7501     PL_multiline        = proto_perl->Imultiline;
7502     PL_statusvalue      = proto_perl->Istatusvalue;
7503 #ifdef VMS
7504     PL_statusvalue_vms  = proto_perl->Istatusvalue_vms;
7505 #endif
7506
7507     /* shortcuts to various I/O objects */
7508     PL_stdingv          = gv_dup(proto_perl->Istdingv);
7509     PL_stderrgv         = gv_dup(proto_perl->Istderrgv);
7510     PL_defgv            = gv_dup(proto_perl->Idefgv);
7511     PL_argvgv           = gv_dup(proto_perl->Iargvgv);
7512     PL_argvoutgv        = gv_dup(proto_perl->Iargvoutgv);
7513     PL_argvout_stack    = av_dup(proto_perl->Iargvout_stack);
7514
7515     /* shortcuts to regexp stuff */
7516     PL_replgv           = gv_dup(proto_perl->Ireplgv);
7517
7518     /* shortcuts to misc objects */
7519     PL_errgv            = gv_dup(proto_perl->Ierrgv);
7520
7521     /* shortcuts to debugging objects */
7522     PL_DBgv             = gv_dup(proto_perl->IDBgv);
7523     PL_DBline           = gv_dup(proto_perl->IDBline);
7524     PL_DBsub            = gv_dup(proto_perl->IDBsub);
7525     PL_DBsingle         = sv_dup(proto_perl->IDBsingle);
7526     PL_DBtrace          = sv_dup(proto_perl->IDBtrace);
7527     PL_DBsignal         = sv_dup(proto_perl->IDBsignal);
7528     PL_lineary          = av_dup(proto_perl->Ilineary);
7529     PL_dbargs           = av_dup(proto_perl->Idbargs);
7530
7531     /* symbol tables */
7532     PL_defstash         = hv_dup_inc(proto_perl->Tdefstash);
7533     PL_curstash         = hv_dup(proto_perl->Tcurstash);
7534     PL_debstash         = hv_dup(proto_perl->Idebstash);
7535     PL_globalstash      = hv_dup(proto_perl->Iglobalstash);
7536     PL_curstname        = sv_dup_inc(proto_perl->Icurstname);
7537
7538     PL_beginav          = av_dup_inc(proto_perl->Ibeginav);
7539     PL_endav            = av_dup_inc(proto_perl->Iendav);
7540     PL_checkav          = av_dup_inc(proto_perl->Icheckav);
7541     PL_initav           = av_dup_inc(proto_perl->Iinitav);
7542
7543     PL_sub_generation   = proto_perl->Isub_generation;
7544
7545     /* funky return mechanisms */
7546     PL_forkprocess      = proto_perl->Iforkprocess;
7547
7548     /* subprocess state */
7549     PL_fdpid            = av_dup_inc(proto_perl->Ifdpid);
7550
7551     /* internal state */
7552     PL_tainting         = proto_perl->Itainting;
7553     PL_maxo             = proto_perl->Imaxo;
7554     if (proto_perl->Iop_mask)
7555         PL_op_mask      = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7556     else
7557         PL_op_mask      = Nullch;
7558
7559     /* current interpreter roots */
7560     PL_main_cv          = cv_dup_inc(proto_perl->Imain_cv);
7561     PL_main_root        = OpREFCNT_inc(proto_perl->Imain_root);
7562     PL_main_start       = proto_perl->Imain_start;
7563     PL_eval_root        = OpREFCNT_inc(proto_perl->Ieval_root);
7564     PL_eval_start       = proto_perl->Ieval_start;
7565
7566     /* runtime control stuff */
7567     PL_curcopdb         = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7568     PL_copline          = proto_perl->Icopline;
7569
7570     PL_filemode         = proto_perl->Ifilemode;
7571     PL_lastfd           = proto_perl->Ilastfd;
7572     PL_oldname          = proto_perl->Ioldname;         /* XXX not quite right */
7573     PL_Argv             = NULL;
7574     PL_Cmd              = Nullch;
7575     PL_gensym           = proto_perl->Igensym;
7576     PL_preambled        = proto_perl->Ipreambled;
7577     PL_preambleav       = av_dup_inc(proto_perl->Ipreambleav);
7578     PL_laststatval      = proto_perl->Ilaststatval;
7579     PL_laststype        = proto_perl->Ilaststype;
7580     PL_mess_sv          = Nullsv;
7581
7582     PL_orslen           = proto_perl->Iorslen;
7583     PL_ors              = SAVEPVN(proto_perl->Iors, PL_orslen);
7584     PL_ofmt             = SAVEPV(proto_perl->Iofmt);
7585
7586     /* interpreter atexit processing */
7587     PL_exitlistlen      = proto_perl->Iexitlistlen;
7588     if (PL_exitlistlen) {
7589         New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7590         Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7591     }
7592     else
7593         PL_exitlist     = (PerlExitListEntry*)NULL;
7594     PL_modglobal        = hv_dup_inc(proto_perl->Imodglobal);
7595
7596     PL_profiledata      = NULL;
7597     PL_rsfp             = fp_dup(proto_perl->Irsfp, '<');
7598     /* PL_rsfp_filters entries have fake IoDIRP() */
7599     PL_rsfp_filters     = av_dup_inc(proto_perl->Irsfp_filters);
7600
7601     PL_compcv                   = cv_dup(proto_perl->Icompcv);
7602     PL_comppad                  = av_dup(proto_perl->Icomppad);
7603     PL_comppad_name             = av_dup(proto_perl->Icomppad_name);
7604     PL_comppad_name_fill        = proto_perl->Icomppad_name_fill;
7605     PL_comppad_name_floor       = proto_perl->Icomppad_name_floor;
7606     PL_curpad                   = (SV**)ptr_table_fetch(PL_ptr_table,
7607                                                         proto_perl->Tcurpad);
7608
7609 #ifdef HAVE_INTERP_INTERN
7610     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7611 #endif
7612
7613     /* more statics moved here */
7614     PL_generation       = proto_perl->Igeneration;
7615     PL_DBcv             = cv_dup(proto_perl->IDBcv);
7616
7617     PL_in_clean_objs    = proto_perl->Iin_clean_objs;
7618     PL_in_clean_all     = proto_perl->Iin_clean_all;
7619
7620     PL_uid              = proto_perl->Iuid;
7621     PL_euid             = proto_perl->Ieuid;
7622     PL_gid              = proto_perl->Igid;
7623     PL_egid             = proto_perl->Iegid;
7624     PL_nomemok          = proto_perl->Inomemok;
7625     PL_an               = proto_perl->Ian;
7626     PL_cop_seqmax       = proto_perl->Icop_seqmax;
7627     PL_op_seqmax        = proto_perl->Iop_seqmax;
7628     PL_evalseq          = proto_perl->Ievalseq;
7629     PL_origenviron      = proto_perl->Iorigenviron;     /* XXX not quite right */
7630     PL_origalen         = proto_perl->Iorigalen;
7631     PL_pidstatus        = newHV();                      /* XXX flag for cloning? */
7632     PL_osname           = SAVEPV(proto_perl->Iosname);
7633     PL_sh_path          = SAVEPV(proto_perl->Ish_path);
7634     PL_sighandlerp      = proto_perl->Isighandlerp;
7635
7636
7637     PL_runops           = proto_perl->Irunops;
7638
7639     Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7640
7641 #ifdef CSH
7642     PL_cshlen           = proto_perl->Icshlen;
7643     PL_cshname          = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7644 #endif
7645
7646     PL_lex_state        = proto_perl->Ilex_state;
7647     PL_lex_defer        = proto_perl->Ilex_defer;
7648     PL_lex_expect       = proto_perl->Ilex_expect;
7649     PL_lex_formbrack    = proto_perl->Ilex_formbrack;
7650     PL_lex_dojoin       = proto_perl->Ilex_dojoin;
7651     PL_lex_starts       = proto_perl->Ilex_starts;
7652     PL_lex_stuff        = sv_dup_inc(proto_perl->Ilex_stuff);
7653     PL_lex_repl         = sv_dup_inc(proto_perl->Ilex_repl);
7654     PL_lex_op           = proto_perl->Ilex_op;
7655     PL_lex_inpat        = proto_perl->Ilex_inpat;
7656     PL_lex_inwhat       = proto_perl->Ilex_inwhat;
7657     PL_lex_brackets     = proto_perl->Ilex_brackets;
7658     i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7659     PL_lex_brackstack   = SAVEPVN(proto_perl->Ilex_brackstack,i);
7660     PL_lex_casemods     = proto_perl->Ilex_casemods;
7661     i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7662     PL_lex_casestack    = SAVEPVN(proto_perl->Ilex_casestack,i);
7663
7664     Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7665     Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7666     PL_nexttoke         = proto_perl->Inexttoke;
7667
7668     PL_linestr          = sv_dup_inc(proto_perl->Ilinestr);
7669     i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7670     PL_bufptr           = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7671     i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7672     PL_oldbufptr        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7673     i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7674     PL_oldoldbufptr     = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7675     PL_bufend           = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7676     i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7677     PL_linestart        = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7678     PL_pending_ident    = proto_perl->Ipending_ident;
7679     PL_sublex_info      = proto_perl->Isublex_info;     /* XXX not quite right */
7680
7681     PL_expect           = proto_perl->Iexpect;
7682
7683     PL_multi_start      = proto_perl->Imulti_start;
7684     PL_multi_end        = proto_perl->Imulti_end;
7685     PL_multi_open       = proto_perl->Imulti_open;
7686     PL_multi_close      = proto_perl->Imulti_close;
7687
7688     PL_error_count      = proto_perl->Ierror_count;
7689     PL_subline          = proto_perl->Isubline;
7690     PL_subname          = sv_dup_inc(proto_perl->Isubname);
7691
7692     PL_min_intro_pending        = proto_perl->Imin_intro_pending;
7693     PL_max_intro_pending        = proto_perl->Imax_intro_pending;
7694     PL_padix                    = proto_perl->Ipadix;
7695     PL_padix_floor              = proto_perl->Ipadix_floor;
7696     PL_pad_reset_pending        = proto_perl->Ipad_reset_pending;
7697
7698     i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7699     PL_last_uni         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7700     i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7701     PL_last_lop         = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7702     PL_last_lop_op      = proto_perl->Ilast_lop_op;
7703     PL_in_my            = proto_perl->Iin_my;
7704     PL_in_my_stash      = hv_dup(proto_perl->Iin_my_stash);
7705 #ifdef FCRYPT
7706     PL_cryptseen        = proto_perl->Icryptseen;
7707 #endif
7708
7709     PL_hints            = proto_perl->Ihints;
7710
7711     PL_amagic_generation        = proto_perl->Iamagic_generation;
7712
7713 #ifdef USE_LOCALE_COLLATE
7714     PL_collation_ix     = proto_perl->Icollation_ix;
7715     PL_collation_name   = SAVEPV(proto_perl->Icollation_name);
7716     PL_collation_standard       = proto_perl->Icollation_standard;
7717     PL_collxfrm_base    = proto_perl->Icollxfrm_base;
7718     PL_collxfrm_mult    = proto_perl->Icollxfrm_mult;
7719 #endif /* USE_LOCALE_COLLATE */
7720
7721 #ifdef USE_LOCALE_NUMERIC
7722     PL_numeric_name     = SAVEPV(proto_perl->Inumeric_name);
7723     PL_numeric_standard = proto_perl->Inumeric_standard;
7724     PL_numeric_local    = proto_perl->Inumeric_local;
7725     PL_numeric_radix    = proto_perl->Inumeric_radix;
7726 #endif /* !USE_LOCALE_NUMERIC */
7727
7728     /* utf8 character classes */
7729     PL_utf8_alnum       = sv_dup_inc(proto_perl->Iutf8_alnum);
7730     PL_utf8_alnumc      = sv_dup_inc(proto_perl->Iutf8_alnumc);
7731     PL_utf8_ascii       = sv_dup_inc(proto_perl->Iutf8_ascii);
7732     PL_utf8_alpha       = sv_dup_inc(proto_perl->Iutf8_alpha);
7733     PL_utf8_space       = sv_dup_inc(proto_perl->Iutf8_space);
7734     PL_utf8_cntrl       = sv_dup_inc(proto_perl->Iutf8_cntrl);
7735     PL_utf8_graph       = sv_dup_inc(proto_perl->Iutf8_graph);
7736     PL_utf8_digit       = sv_dup_inc(proto_perl->Iutf8_digit);
7737     PL_utf8_upper       = sv_dup_inc(proto_perl->Iutf8_upper);
7738     PL_utf8_lower       = sv_dup_inc(proto_perl->Iutf8_lower);
7739     PL_utf8_print       = sv_dup_inc(proto_perl->Iutf8_print);
7740     PL_utf8_punct       = sv_dup_inc(proto_perl->Iutf8_punct);
7741     PL_utf8_xdigit      = sv_dup_inc(proto_perl->Iutf8_xdigit);
7742     PL_utf8_mark        = sv_dup_inc(proto_perl->Iutf8_mark);
7743     PL_utf8_toupper     = sv_dup_inc(proto_perl->Iutf8_toupper);
7744     PL_utf8_totitle     = sv_dup_inc(proto_perl->Iutf8_totitle);
7745     PL_utf8_tolower     = sv_dup_inc(proto_perl->Iutf8_tolower);
7746
7747     /* swatch cache */
7748     PL_last_swash_hv    = Nullhv;       /* reinits on demand */
7749     PL_last_swash_klen  = 0;
7750     PL_last_swash_key[0]= '\0';
7751     PL_last_swash_tmps  = (U8*)NULL;
7752     PL_last_swash_slen  = 0;
7753
7754     /* perly.c globals */
7755     PL_yydebug          = proto_perl->Iyydebug;
7756     PL_yynerrs          = proto_perl->Iyynerrs;
7757     PL_yyerrflag        = proto_perl->Iyyerrflag;
7758     PL_yychar           = proto_perl->Iyychar;
7759     PL_yyval            = proto_perl->Iyyval;
7760     PL_yylval           = proto_perl->Iyylval;
7761
7762     PL_glob_index       = proto_perl->Iglob_index;
7763     PL_srand_called     = proto_perl->Isrand_called;
7764     PL_uudmap['M']      = 0;            /* reinits on demand */
7765     PL_bitcount         = Nullch;       /* reinits on demand */
7766
7767     if (proto_perl->Ipsig_ptr) {
7768         int sig_num[] = { SIG_NUM };
7769         Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7770         Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7771         for (i = 1; PL_sig_name[i]; i++) {
7772             PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7773             PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7774         }
7775     }
7776     else {
7777         PL_psig_ptr     = (SV**)NULL;
7778         PL_psig_name    = (SV**)NULL;
7779     }
7780
7781     /* thrdvar.h stuff */
7782
7783     if (flags & 1) {
7784         /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7785         PL_tmps_ix              = proto_perl->Ttmps_ix;
7786         PL_tmps_max             = proto_perl->Ttmps_max;
7787         PL_tmps_floor           = proto_perl->Ttmps_floor;
7788         Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7789         i = 0;
7790         while (i <= PL_tmps_ix) {
7791             PL_tmps_stack[i]    = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7792             ++i;
7793         }
7794
7795         /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7796         i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7797         Newz(54, PL_markstack, i, I32);
7798         PL_markstack_max        = PL_markstack + (proto_perl->Tmarkstack_max
7799                                                   - proto_perl->Tmarkstack);
7800         PL_markstack_ptr        = PL_markstack + (proto_perl->Tmarkstack_ptr
7801                                                   - proto_perl->Tmarkstack);
7802         Copy(proto_perl->Tmarkstack, PL_markstack,
7803              PL_markstack_ptr - PL_markstack + 1, I32);
7804
7805         /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7806          * NOTE: unlike the others! */
7807         PL_scopestack_ix        = proto_perl->Tscopestack_ix;
7808         PL_scopestack_max       = proto_perl->Tscopestack_max;
7809         Newz(54, PL_scopestack, PL_scopestack_max, I32);
7810         Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7811
7812         /* next push_return() sets PL_retstack[PL_retstack_ix]
7813          * NOTE: unlike the others! */
7814         PL_retstack_ix          = proto_perl->Tretstack_ix;
7815         PL_retstack_max         = proto_perl->Tretstack_max;
7816         Newz(54, PL_retstack, PL_retstack_max, OP*);
7817         Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7818
7819         /* NOTE: si_dup() looks at PL_markstack */
7820         PL_curstackinfo         = si_dup(proto_perl->Tcurstackinfo);
7821
7822         /* PL_curstack          = PL_curstackinfo->si_stack; */
7823         PL_curstack             = av_dup(proto_perl->Tcurstack);
7824         PL_mainstack            = av_dup(proto_perl->Tmainstack);
7825
7826         /* next PUSHs() etc. set *(PL_stack_sp+1) */
7827         PL_stack_base           = AvARRAY(PL_curstack);
7828         PL_stack_sp             = PL_stack_base + (proto_perl->Tstack_sp
7829                                                    - proto_perl->Tstack_base);
7830         PL_stack_max            = PL_stack_base + AvMAX(PL_curstack);
7831
7832         /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7833          * NOTE: unlike the others! */
7834         PL_savestack_ix         = proto_perl->Tsavestack_ix;
7835         PL_savestack_max        = proto_perl->Tsavestack_max;
7836         /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7837         PL_savestack            = ss_dup(proto_perl);
7838     }
7839     else {
7840         init_stacks();
7841     }
7842
7843     PL_start_env        = proto_perl->Tstart_env;       /* XXXXXX */
7844     PL_top_env          = &PL_start_env;
7845
7846     PL_op               = proto_perl->Top;
7847
7848     PL_Sv               = Nullsv;
7849     PL_Xpv              = (XPV*)NULL;
7850     PL_na               = proto_perl->Tna;
7851
7852     PL_statbuf          = proto_perl->Tstatbuf;
7853     PL_statcache        = proto_perl->Tstatcache;
7854     PL_statgv           = gv_dup(proto_perl->Tstatgv);
7855     PL_statname         = sv_dup_inc(proto_perl->Tstatname);
7856 #ifdef HAS_TIMES
7857     PL_timesbuf         = proto_perl->Ttimesbuf;
7858 #endif
7859
7860     PL_tainted          = proto_perl->Ttainted;
7861     PL_curpm            = proto_perl->Tcurpm;   /* XXX No PMOP ref count */
7862     PL_nrs              = sv_dup_inc(proto_perl->Tnrs);
7863     PL_rs               = sv_dup_inc(proto_perl->Trs);
7864     PL_last_in_gv       = gv_dup(proto_perl->Tlast_in_gv);
7865     PL_ofslen           = proto_perl->Tofslen;
7866     PL_ofs              = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7867     PL_defoutgv         = gv_dup_inc(proto_perl->Tdefoutgv);
7868     PL_chopset          = proto_perl->Tchopset; /* XXX never deallocated */
7869     PL_toptarget        = sv_dup_inc(proto_perl->Ttoptarget);
7870     PL_bodytarget       = sv_dup_inc(proto_perl->Tbodytarget);
7871     PL_formtarget       = sv_dup(proto_perl->Tformtarget);
7872
7873     PL_restartop        = proto_perl->Trestartop;
7874     PL_in_eval          = proto_perl->Tin_eval;
7875     PL_delaymagic       = proto_perl->Tdelaymagic;
7876     PL_dirty            = proto_perl->Tdirty;
7877     PL_localizing       = proto_perl->Tlocalizing;
7878
7879 #ifdef PERL_FLEXIBLE_EXCEPTIONS
7880     PL_protect          = proto_perl->Tprotect;
7881 #endif
7882     PL_errors           = sv_dup_inc(proto_perl->Terrors);
7883     PL_av_fetch_sv      = Nullsv;
7884     PL_hv_fetch_sv      = Nullsv;
7885     Zero(&PL_hv_fetch_ent_mh, 1, HE);                   /* XXX */
7886     PL_modcount         = proto_perl->Tmodcount;
7887     PL_lastgotoprobe    = Nullop;
7888     PL_dumpindent       = proto_perl->Tdumpindent;
7889
7890     PL_sortcop          = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7891     PL_sortstash        = hv_dup(proto_perl->Tsortstash);
7892     PL_firstgv          = gv_dup(proto_perl->Tfirstgv);
7893     PL_secondgv         = gv_dup(proto_perl->Tsecondgv);
7894     PL_sortcxix         = proto_perl->Tsortcxix;
7895     PL_efloatbuf        = Nullch;               /* reinits on demand */
7896     PL_efloatsize       = 0;                    /* reinits on demand */
7897
7898     /* regex stuff */
7899
7900     PL_screamfirst      = NULL;
7901     PL_screamnext       = NULL;
7902     PL_maxscream        = -1;                   /* reinits on demand */
7903     PL_lastscream       = Nullsv;
7904
7905     PL_watchaddr        = NULL;
7906     PL_watchok          = Nullch;
7907
7908     PL_regdummy         = proto_perl->Tregdummy;
7909     PL_regcomp_parse    = Nullch;
7910     PL_regxend          = Nullch;
7911     PL_regcode          = (regnode*)NULL;
7912     PL_regnaughty       = 0;
7913     PL_regsawback       = 0;
7914     PL_regprecomp       = Nullch;
7915     PL_regnpar          = 0;
7916     PL_regsize          = 0;
7917     PL_regflags         = 0;
7918     PL_regseen          = 0;
7919     PL_seen_zerolen     = 0;
7920     PL_seen_evals       = 0;
7921     PL_regcomp_rx       = (regexp*)NULL;
7922     PL_extralen         = 0;
7923     PL_colorset         = 0;            /* reinits PL_colors[] */
7924     /*PL_colors[6]      = {0,0,0,0,0,0};*/
7925     PL_reg_whilem_seen  = 0;
7926     PL_reginput         = Nullch;
7927     PL_regbol           = Nullch;
7928     PL_regeol           = Nullch;
7929     PL_regstartp        = (I32*)NULL;
7930     PL_regendp          = (I32*)NULL;
7931     PL_reglastparen     = (U32*)NULL;
7932     PL_regtill          = Nullch;
7933     PL_regprev          = '\n';
7934     PL_reg_start_tmp    = (char**)NULL;
7935     PL_reg_start_tmpl   = 0;
7936     PL_regdata          = (struct reg_data*)NULL;
7937     PL_bostr            = Nullch;
7938     PL_reg_flags        = 0;
7939     PL_reg_eval_set     = 0;
7940     PL_regnarrate       = 0;
7941     PL_regprogram       = (regnode*)NULL;
7942     PL_regindent        = 0;
7943     PL_regcc            = (CURCUR*)NULL;
7944     PL_reg_call_cc      = (struct re_cc_state*)NULL;
7945     PL_reg_re           = (regexp*)NULL;
7946     PL_reg_ganch        = Nullch;
7947     PL_reg_sv           = Nullsv;
7948     PL_reg_magic        = (MAGIC*)NULL;
7949     PL_reg_oldpos       = 0;
7950     PL_reg_oldcurpm     = (PMOP*)NULL;
7951     PL_reg_curpm        = (PMOP*)NULL;
7952     PL_reg_oldsaved     = Nullch;
7953     PL_reg_oldsavedlen  = 0;
7954     PL_reg_maxiter      = 0;
7955     PL_reg_leftiter     = 0;
7956     PL_reg_poscache     = Nullch;
7957     PL_reg_poscache_size= 0;
7958
7959     /* RE engine - function pointers */
7960     PL_regcompp         = proto_perl->Tregcompp;
7961     PL_regexecp         = proto_perl->Tregexecp;
7962     PL_regint_start     = proto_perl->Tregint_start;
7963     PL_regint_string    = proto_perl->Tregint_string;
7964     PL_regfree          = proto_perl->Tregfree;
7965
7966     PL_reginterp_cnt    = 0;
7967     PL_reg_starttry     = 0;
7968
7969 #ifdef PERL_OBJECT
7970     return (PerlInterpreter*)pPerl;
7971 #else
7972     return my_perl;
7973 #endif
7974 }
7975
7976 #else   /* !USE_ITHREADS */
7977
7978 #ifdef PERL_OBJECT
7979 #include "XSUB.h"
7980 #endif
7981
7982 #endif /* USE_ITHREADS */
7983
7984 static void
7985 do_report_used(pTHXo_ SV *sv)
7986 {
7987     if (SvTYPE(sv) != SVTYPEMASK) {
7988         PerlIO_printf(Perl_debug_log, "****\n");
7989         sv_dump(sv);
7990     }
7991 }
7992
7993 static void
7994 do_clean_objs(pTHXo_ SV *sv)
7995 {
7996     SV* rv;
7997
7998     if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7999         DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8000         SvROK_off(sv);
8001         SvRV(sv) = 0;
8002         SvREFCNT_dec(rv);
8003     }
8004
8005     /* XXX Might want to check arrays, etc. */
8006 }
8007
8008 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8009 static void
8010 do_clean_named_objs(pTHXo_ SV *sv)
8011 {
8012     if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8013         if ( SvOBJECT(GvSV(sv)) ||
8014              GvAV(sv) && SvOBJECT(GvAV(sv)) ||
8015              GvHV(sv) && SvOBJECT(GvHV(sv)) ||
8016              GvIO(sv) && SvOBJECT(GvIO(sv)) ||
8017              GvCV(sv) && SvOBJECT(GvCV(sv)) )
8018         {
8019             DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8020             SvREFCNT_dec(sv);
8021         }
8022     }
8023 }
8024 #endif
8025
8026 static void
8027 do_clean_all(pTHXo_ SV *sv)
8028 {
8029     DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8030     SvFLAGS(sv) |= SVf_BREAK;
8031     SvREFCNT_dec(sv);
8032 }
8033