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