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