sv.c

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