sv.c

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