pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (c) 1991-2002, 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  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  12  * shaking the air.
  13  *
  14  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  15  *                     Fire, Foes!  Awake!
  16  */
  17
  18 #include "EXTERN.h"
  19 #define PERL_IN_PP_HOT_C
  20 #include "perl.h"
  21
  22 /* Hot code. */
  23
  24 #ifdef USE_5005THREADS
  25 static void unset_cvowner(pTHX_ void *cvarg);
  26 #endif /* USE_5005THREADS */
  27
  28 PP(pp_const)
  29 {
  30     dSP;
  31     XPUSHs(cSVOP_sv);
  32     RETURN;
  33 }
  34
  35 PP(pp_nextstate)
  36 {
  37     PL_curcop = (COP*)PL_op;
  38     TAINT_NOT;          /* Each statement is presumed innocent */
  39     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  40     FREETMPS;
  41     return NORMAL;
  42 }
  43
  44 PP(pp_gvsv)
  45 {
  46     dSP;
  47     EXTEND(SP,1);
  48     if (PL_op->op_private & OPpLVAL_INTRO)
  49         PUSHs(save_scalar(cGVOP_gv));
  50     else
  51         PUSHs(GvSV(cGVOP_gv));
  52     RETURN;
  53 }
  54
  55 PP(pp_null)
  56 {
  57     return NORMAL;
  58 }
  59
  60 PP(pp_setstate)
  61 {
  62     PL_curcop = (COP*)PL_op;
  63     return NORMAL;
  64 }
  65
  66 PP(pp_pushmark)
  67 {
  68     PUSHMARK(PL_stack_sp);
  69     return NORMAL;
  70 }
  71
  72 PP(pp_stringify)
  73 {
  74     dSP; dTARGET;
  75     sv_copypv(TARG,TOPs);
  76     SETTARG;
  77     RETURN;
  78 }
  79
  80 PP(pp_gv)
  81 {
  82     dSP;
  83     XPUSHs((SV*)cGVOP_gv);
  84     RETURN;
  85 }
  86
  87 PP(pp_and)
  88 {
  89     dSP;
  90     if (!SvTRUE(TOPs))
  91         RETURN;
  92     else {
  93         --SP;
  94         RETURNOP(cLOGOP->op_other);
  95     }
  96 }
  97
  98 PP(pp_sassign)
  99 {
 100     dSP; dPOPTOPssrl;
 101
 102     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
 103         SV *temp;
 104         temp = left; left = right; right = temp;
 105     }
 106     if (PL_tainting && PL_tainted && !SvTAINTED(left))
 107         TAINT_NOT;
 108     SvSetMagicSV(right, left);
 109     SETs(right);
 110     RETURN;
 111 }
 112
 113 PP(pp_cond_expr)
 114 {
 115     dSP;
 116     if (SvTRUEx(POPs))
 117         RETURNOP(cLOGOP->op_other);
 118     else
 119         RETURNOP(cLOGOP->op_next);
 120 }
 121
 122 PP(pp_unstack)
 123 {
 124     I32 oldsave;
 125     TAINT_NOT;          /* Each statement is presumed innocent */
 126     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 127     FREETMPS;
 128     oldsave = PL_scopestack[PL_scopestack_ix - 1];
 129     LEAVE_SCOPE(oldsave);
 130     return NORMAL;
 131 }
 132
 133 PP(pp_concat)
 134 {
 135   dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 136   {
 137     dPOPTOPssrl;
 138     STRLEN llen;
 139     char* lpv;
 140     bool lbyte;
 141     STRLEN rlen;
 142     char* rpv = SvPV(right, rlen);      /* mg_get(right) happens here */
 143     bool rbyte = !SvUTF8(right);
 144
 145     if (TARG == right && right != left) {
 146         right = sv_2mortal(newSVpvn(rpv, rlen));
 147         rpv = SvPV(right, rlen);        /* no point setting UTF8 here */
 148     }
 149
 150     if (TARG != left) {
 151         lpv = SvPV(left, llen);         /* mg_get(left) may happen here */
 152         lbyte = !SvUTF8(left);
 153         sv_setpvn(TARG, lpv, llen);
 154         if (!lbyte)
 155             SvUTF8_on(TARG);
 156         else
 157             SvUTF8_off(TARG);
 158     }
 159     else { /* TARG == left */
 160         if (SvGMAGICAL(left))
 161             mg_get(left);               /* or mg_get(left) may happen here */
 162         if (!SvOK(TARG))
 163             sv_setpv(left, "");
 164         lpv = SvPV_nomg(left, llen);
 165         lbyte = !SvUTF8(left);
 166     }
 167
 168 #if defined(PERL_Y2KWARN)
 169     if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
 170         if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
 171             && (llen == 2 || !isDIGIT(lpv[llen - 3])))
 172         {
 173             Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
 174                         "about to append an integer to '19'");
 175         }
 176     }
 177 #endif
 178
 179     if (lbyte != rbyte) {
 180         if (lbyte)
 181             sv_utf8_upgrade_nomg(TARG);
 182         else {
 183             sv_utf8_upgrade_nomg(right);
 184             rpv = SvPV(right, rlen);
 185         }
 186     }
 187     sv_catpvn_nomg(TARG, rpv, rlen);
 188
 189     SETTARG;
 190     RETURN;
 191   }
 192 }
 193
 194 PP(pp_padsv)
 195 {
 196     dSP; dTARGET;
 197     XPUSHs(TARG);
 198     if (PL_op->op_flags & OPf_MOD) {
 199         if (PL_op->op_private & OPpLVAL_INTRO)
 200             SAVECLEARSV(PL_curpad[PL_op->op_targ]);
 201         else if (PL_op->op_private & OPpDEREF) {
 202             PUTBACK;
 203             vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
 204             SPAGAIN;
 205         }
 206     }
 207     RETURN;
 208 }
 209
 210 PP(pp_readline)
 211 {
 212     tryAMAGICunTARGET(iter, 0);
 213     PL_last_in_gv = (GV*)(*PL_stack_sp--);
 214     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
 215         if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
 216             PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
 217         else {
 218             dSP;
 219             XPUSHs((SV*)PL_last_in_gv);
 220             PUTBACK;
 221             pp_rv2gv();
 222             PL_last_in_gv = (GV*)(*PL_stack_sp--);
 223         }
 224     }
 225     return do_readline();
 226 }
 227
 228 PP(pp_eq)
 229 {
 230     dSP; tryAMAGICbinSET(eq,0);
 231 #ifndef NV_PRESERVES_UV
 232     if (SvROK(TOPs) && SvROK(TOPm1s)) {
 233         SP--;
 234         SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
 235         RETURN;
 236     }
 237 #endif
 238 #ifdef PERL_PRESERVE_IVUV
 239     SvIV_please(TOPs);
 240     if (SvIOK(TOPs)) {
 241         /* Unless the left argument is integer in range we are going
 242            to have to use NV maths. Hence only attempt to coerce the
 243            right argument if we know the left is integer.  */
 244       SvIV_please(TOPm1s);
 245         if (SvIOK(TOPm1s)) {
 246             bool auvok = SvUOK(TOPm1s);
 247             bool buvok = SvUOK(TOPs);
 248
 249             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
 250                 /* Casting IV to UV before comparison isn't going to matter
 251                    on 2s complement. On 1s complement or sign&magnitude
 252                    (if we have any of them) it could to make negative zero
 253                    differ from normal zero. As I understand it. (Need to
 254                    check - is negative zero implementation defined behaviour
 255                    anyway?). NWC  */
 256                 UV buv = SvUVX(POPs);
 257                 UV auv = SvUVX(TOPs);
 258
 259                 SETs(boolSV(auv == buv));
 260                 RETURN;
 261             }
 262             {                   /* ## Mixed IV,UV ## */
 263                 SV *ivp, *uvp;
 264                 IV iv;
 265
 266                 /* == is commutative so doesn't matter which is left or right */
 267                 if (auvok) {
 268                     /* top of stack (b) is the iv */
 269                     ivp = *SP;
 270                     uvp = *--SP;
 271                 } else {
 272                     uvp = *SP;
 273                     ivp = *--SP;
 274                 }
 275                 iv = SvIVX(ivp);
 276                 if (iv < 0) {
 277                     /* As uv is a UV, it's >0, so it cannot be == */
 278                     SETs(&PL_sv_no);
 279                     RETURN;
 280                 }
 281                 /* we know iv is >= 0 */
 282                 SETs(boolSV((UV)iv == SvUVX(uvp)));
 283                 RETURN;
 284             }
 285         }
 286     }
 287 #endif
 288     {
 289       dPOPnv;
 290       SETs(boolSV(TOPn == value));
 291       RETURN;
 292     }
 293 }
 294
 295 PP(pp_preinc)
 296 {
 297     dSP;
 298     if (SvTYPE(TOPs) > SVt_PVLV)
 299         DIE(aTHX_ PL_no_modify);
 300     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 301         && SvIVX(TOPs) != IV_MAX)
 302     {
 303         ++SvIVX(TOPs);
 304         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 305     }
 306     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
 307         sv_inc(TOPs);
 308     SvSETMAGIC(TOPs);
 309     return NORMAL;
 310 }
 311
 312 PP(pp_or)
 313 {
 314     dSP;
 315     if (SvTRUE(TOPs))
 316         RETURN;
 317     else {
 318         --SP;
 319         RETURNOP(cLOGOP->op_other);
 320     }
 321 }
 322
 323 PP(pp_dor)
 324 {
 325     /* Most of this is lifted straight from pp_defined */
 326     dSP;
 327     register SV* sv;
 328
 329     sv = TOPs;
 330     if (!sv || !SvANY(sv)) {
 331         --SP;
 332         RETURNOP(cLOGOP->op_other);
 333     }
 334
 335     switch (SvTYPE(sv)) {
 336     case SVt_PVAV:
 337         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 338             RETURN;
 339         break;
 340     case SVt_PVHV:
 341         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 342             RETURN;
 343         break;
 344     case SVt_PVCV:
 345         if (CvROOT(sv) || CvXSUB(sv))
 346             RETURN;
 347         break;
 348     default:
 349         if (SvGMAGICAL(sv))
 350             mg_get(sv);
 351         if (SvOK(sv))
 352             RETURN;
 353     }
 354
 355     --SP;
 356     RETURNOP(cLOGOP->op_other);
 357 }
 358
 359 PP(pp_add)
 360 {
 361     dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
 362     useleft = USE_LEFT(TOPm1s);
 363 #ifdef PERL_PRESERVE_IVUV
 364     /* We must see if we can perform the addition with integers if possible,
 365        as the integer code detects overflow while the NV code doesn't.
 366        If either argument hasn't had a numeric conversion yet attempt to get
 367        the IV. It's important to do this now, rather than just assuming that
 368        it's not IOK as a PV of "9223372036854775806" may not take well to NV
 369        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
 370        integer in case the second argument is IV=9223372036854775806
 371        We can (now) rely on sv_2iv to do the right thing, only setting the
 372        public IOK flag if the value in the NV (or PV) slot is truly integer.
 373
 374        A side effect is that this also aggressively prefers integer maths over
 375        fp maths for integer values.
 376
 377        How to detect overflow?
 378
 379        C 99 section 6.2.6.1 says
 380
 381        The range of nonnegative values of a signed integer type is a subrange
 382        of the corresponding unsigned integer type, and the representation of
 383        the same value in each type is the same. A computation involving
 384        unsigned operands can never overflow, because a result that cannot be
 385        represented by the resulting unsigned integer type is reduced modulo
 386        the number that is one greater than the largest value that can be
 387        represented by the resulting type.
 388
 389        (the 9th paragraph)
 390
 391        which I read as "unsigned ints wrap."
 392
 393        signed integer overflow seems to be classed as "exception condition"
 394
 395        If an exceptional condition occurs during the evaluation of an
 396        expression (that is, if the result is not mathematically defined or not
 397        in the range of representable values for its type), the behavior is
 398        undefined.
 399
 400        (6.5, the 5th paragraph)
 401
 402        I had assumed that on 2s complement machines signed arithmetic would
 403        wrap, hence coded pp_add and pp_subtract on the assumption that
 404        everything perl builds on would be happy.  After much wailing and
 405        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
 406        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
 407        unsigned code below is actually shorter than the old code. :-)
 408     */
 409
 410     SvIV_please(TOPs);
 411     if (SvIOK(TOPs)) {
 412         /* Unless the left argument is integer in range we are going to have to
 413            use NV maths. Hence only attempt to coerce the right argument if
 414            we know the left is integer.  */
 415         register UV auv = 0;
 416         bool auvok = FALSE;
 417         bool a_valid = 0;
 418
 419         if (!useleft) {
 420             auv = 0;
 421             a_valid = auvok = 1;
 422             /* left operand is undef, treat as zero. + 0 is identity,
 423                Could SETi or SETu right now, but space optimise by not adding
 424                lots of code to speed up what is probably a rarish case.  */
 425         } else {
 426             /* Left operand is defined, so is it IV? */
 427             SvIV_please(TOPm1s);
 428             if (SvIOK(TOPm1s)) {
 429                 if ((auvok = SvUOK(TOPm1s)))
 430                     auv = SvUVX(TOPm1s);
 431                 else {
 432                     register IV aiv = SvIVX(TOPm1s);
 433                     if (aiv >= 0) {
 434                         auv = aiv;
 435                         auvok = 1;      /* Now acting as a sign flag.  */
 436                     } else { /* 2s complement assumption for IV_MIN */
 437                         auv = (UV)-aiv;
 438                     }
 439                 }
 440                 a_valid = 1;
 441             }
 442         }
 443         if (a_valid) {
 444             bool result_good = 0;
 445             UV result;
 446             register UV buv;
 447             bool buvok = SvUOK(TOPs);
 448
 449             if (buvok)
 450                 buv = SvUVX(TOPs);
 451             else {
 452                 register IV biv = SvIVX(TOPs);
 453                 if (biv >= 0) {
 454                     buv = biv;
 455                     buvok = 1;
 456                 } else
 457                     buv = (UV)-biv;
 458             }
 459             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
 460                else "IV" now, independent of how it came in.
 461                if a, b represents positive, A, B negative, a maps to -A etc
 462                a + b =>  (a + b)
 463                A + b => -(a - b)
 464                a + B =>  (a - b)
 465                A + B => -(a + b)
 466                all UV maths. negate result if A negative.
 467                add if signs same, subtract if signs differ. */
 468
 469             if (auvok ^ buvok) {
 470                 /* Signs differ.  */
 471                 if (auv >= buv) {
 472                     result = auv - buv;
 473                     /* Must get smaller */
 474                     if (result <= auv)
 475                         result_good = 1;
 476                 } else {
 477                     result = buv - auv;
 478                     if (result <= buv) {
 479                         /* result really should be -(auv-buv). as its negation
 480                            of true value, need to swap our result flag  */
 481                         auvok = !auvok;
 482                         result_good = 1;
 483                     }
 484                 }
 485             } else {
 486                 /* Signs same */
 487                 result = auv + buv;
 488                 if (result >= auv)
 489                     result_good = 1;
 490             }
 491             if (result_good) {
 492                 SP--;
 493                 if (auvok)
 494                     SETu( result );
 495                 else {
 496                     /* Negate result */
 497                     if (result <= (UV)IV_MIN)
 498                         SETi( -(IV)result );
 499                     else {
 500                         /* result valid, but out of range for IV.  */
 501                         SETn( -(NV)result );
 502                     }
 503                 }
 504                 RETURN;
 505             } /* Overflow, drop through to NVs.  */
 506         }
 507     }
 508 #endif
 509     {
 510         dPOPnv;
 511         if (!useleft) {
 512             /* left operand is undef, treat as zero. + 0.0 is identity. */
 513             SETn(value);
 514             RETURN;
 515         }
 516         SETn( value + TOPn );
 517         RETURN;
 518     }
 519 }
 520
 521 PP(pp_aelemfast)
 522 {
 523     dSP;
 524     AV *av = GvAV(cGVOP_gv);
 525     U32 lval = PL_op->op_flags & OPf_MOD;
 526     SV** svp = av_fetch(av, PL_op->op_private, lval);
 527     SV *sv = (svp ? *svp : &PL_sv_undef);
 528     EXTEND(SP, 1);
 529     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
 530         sv = sv_mortalcopy(sv);
 531     PUSHs(sv);
 532     RETURN;
 533 }
 534
 535 PP(pp_join)
 536 {
 537     dSP; dMARK; dTARGET;
 538     MARK++;
 539     do_join(TARG, *MARK, MARK, SP);
 540     SP = MARK;
 541     SETs(TARG);
 542     RETURN;
 543 }
 544
 545 PP(pp_pushre)
 546 {
 547     dSP;
 548 #ifdef DEBUGGING
 549     /*
 550      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 551      * will be enough to hold an OP*.
 552      */
 553     SV* sv = sv_newmortal();
 554     sv_upgrade(sv, SVt_PVLV);
 555     LvTYPE(sv) = '/';
 556     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
 557     XPUSHs(sv);
 558 #else
 559     XPUSHs((SV*)PL_op);
 560 #endif
 561     RETURN;
 562 }
 563
 564 /* Oversized hot code. */
 565
 566 PP(pp_print)
 567 {
 568     dSP; dMARK; dORIGMARK;
 569     GV *gv;
 570     IO *io;
 571     register PerlIO *fp;
 572     MAGIC *mg;
 573
 574     if (PL_op->op_flags & OPf_STACKED)
 575         gv = (GV*)*++MARK;
 576     else
 577         gv = PL_defoutgv;
 578
 579     if (gv && (io = GvIO(gv))
 580         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 581     {
 582       had_magic:
 583         if (MARK == ORIGMARK) {
 584             /* If using default handle then we need to make space to
 585              * pass object as 1st arg, so move other args up ...
 586              */
 587             MEXTEND(SP, 1);
 588             ++MARK;
 589             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 590             ++SP;
 591         }
 592         PUSHMARK(MARK - 1);
 593         *MARK = SvTIED_obj((SV*)io, mg);
 594         PUTBACK;
 595         ENTER;
 596         call_method("PRINT", G_SCALAR);
 597         LEAVE;
 598         SPAGAIN;
 599         MARK = ORIGMARK + 1;
 600         *MARK = *SP;
 601         SP = MARK;
 602         RETURN;
 603     }
 604     if (!(io = GvIO(gv))) {
 605         if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
 606             && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 607             goto had_magic;
 608         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 609             report_evil_fh(gv, io, PL_op->op_type);
 610         SETERRNO(EBADF,RMS$_IFI);
 611         goto just_say_no;
 612     }
 613     else if (!(fp = IoOFP(io))) {
 614         if (ckWARN2(WARN_CLOSED, WARN_IO))  {
 615             if (IoIFP(io))
 616                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
 617             else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 618                 report_evil_fh(gv, io, PL_op->op_type);
 619         }
 620         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
 621         goto just_say_no;
 622     }
 623     else {
 624         MARK++;
 625         if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
 626             while (MARK <= SP) {
 627                 if (!do_print(*MARK, fp))
 628                     break;
 629                 MARK++;
 630                 if (MARK <= SP) {
 631                     if (!do_print(PL_ofs_sv, fp)) { /* $, */
 632                         MARK--;
 633                         break;
 634                     }
 635                 }
 636             }
 637         }
 638         else {
 639             while (MARK <= SP) {
 640                 if (!do_print(*MARK, fp))
 641                     break;
 642                 MARK++;
 643             }
 644         }
 645         if (MARK <= SP)
 646             goto just_say_no;
 647         else {
 648             if (PL_ors_sv && SvOK(PL_ors_sv))
 649                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 650                     goto just_say_no;
 651
 652             if (IoFLAGS(io) & IOf_FLUSH)
 653                 if (PerlIO_flush(fp) == EOF)
 654                     goto just_say_no;
 655         }
 656     }
 657     SP = ORIGMARK;
 658     PUSHs(&PL_sv_yes);
 659     RETURN;
 660
 661   just_say_no:
 662     SP = ORIGMARK;
 663     PUSHs(&PL_sv_undef);
 664     RETURN;
 665 }
 666
 667 PP(pp_rv2av)
 668 {
 669     dSP; dTOPss;
 670     AV *av;
 671
 672     if (SvROK(sv)) {
 673       wasref:
 674         tryAMAGICunDEREF(to_av);
 675
 676         av = (AV*)SvRV(sv);
 677         if (SvTYPE(av) != SVt_PVAV)
 678             DIE(aTHX_ "Not an ARRAY reference");
 679         if (PL_op->op_flags & OPf_REF) {
 680             SETs((SV*)av);
 681             RETURN;
 682         }
 683         else if (LVRET) {
 684             if (GIMME == G_SCALAR)
 685                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
 686             SETs((SV*)av);
 687             RETURN;
 688         }
 689     }
 690     else {
 691         if (SvTYPE(sv) == SVt_PVAV) {
 692             av = (AV*)sv;
 693             if (PL_op->op_flags & OPf_REF) {
 694                 SETs((SV*)av);
 695                 RETURN;
 696             }
 697             else if (LVRET) {
 698                 if (GIMME == G_SCALAR)
 699                     Perl_croak(aTHX_ "Can't return array to lvalue"
 700                                " scalar context");
 701                 SETs((SV*)av);
 702                 RETURN;
 703             }
 704         }
 705         else {
 706             GV *gv;
 707
 708             if (SvTYPE(sv) != SVt_PVGV) {
 709                 char *sym;
 710                 STRLEN len;
 711
 712                 if (SvGMAGICAL(sv)) {
 713                     mg_get(sv);
 714                     if (SvROK(sv))
 715                         goto wasref;
 716                 }
 717                 if (!SvOK(sv)) {
 718                     if (PL_op->op_flags & OPf_REF ||
 719                       PL_op->op_private & HINT_STRICT_REFS)
 720                         DIE(aTHX_ PL_no_usym, "an ARRAY");
 721                     if (ckWARN(WARN_UNINITIALIZED))
 722                         report_uninit();
 723                     if (GIMME == G_ARRAY) {
 724                         (void)POPs;
 725                         RETURN;
 726                     }
 727                     RETSETUNDEF;
 728                 }
 729                 sym = SvPV(sv,len);
 730                 if ((PL_op->op_flags & OPf_SPECIAL) &&
 731                     !(PL_op->op_flags & OPf_MOD))
 732                 {
 733                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
 734                     if (!gv
 735                         && (!is_gv_magical(sym,len,0)
 736                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
 737                     {
 738                         RETSETUNDEF;
 739                     }
 740                 }
 741                 else {
 742                     if (PL_op->op_private & HINT_STRICT_REFS)
 743                         DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
 744                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
 745                 }
 746             }
 747             else {
 748                 gv = (GV*)sv;
 749             }
 750             av = GvAVn(gv);
 751             if (PL_op->op_private & OPpLVAL_INTRO)
 752                 av = save_ary(gv);
 753             if (PL_op->op_flags & OPf_REF) {
 754                 SETs((SV*)av);
 755                 RETURN;
 756             }
 757             else if (LVRET) {
 758                 if (GIMME == G_SCALAR)
 759                     Perl_croak(aTHX_ "Can't return array to lvalue"
 760                                " scalar context");
 761                 SETs((SV*)av);
 762                 RETURN;
 763             }
 764         }
 765     }
 766
 767     if (GIMME == G_ARRAY) {
 768         I32 maxarg = AvFILL(av) + 1;
 769         (void)POPs;                     /* XXXX May be optimized away? */
 770         EXTEND(SP, maxarg);
 771         if (SvRMAGICAL(av)) {
 772             U32 i;
 773             for (i=0; i < (U32)maxarg; i++) {
 774                 SV **svp = av_fetch(av, i, FALSE);
 775                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
 776             }
 777         }
 778         else {
 779             Copy(AvARRAY(av), SP+1, maxarg, SV*);
 780         }
 781         SP += maxarg;
 782     }
 783     else {
 784         dTARGET;
 785         I32 maxarg = AvFILL(av) + 1;
 786         SETi(maxarg);
 787     }
 788     RETURN;
 789 }
 790
 791 PP(pp_rv2hv)
 792 {
 793     dSP; dTOPss;
 794     HV *hv;
 795
 796     if (SvROK(sv)) {
 797       wasref:
 798         tryAMAGICunDEREF(to_hv);
 799
 800         hv = (HV*)SvRV(sv);
 801         if (SvTYPE(hv) != SVt_PVHV)
 802             DIE(aTHX_ "Not a HASH reference");
 803         if (PL_op->op_flags & OPf_REF) {
 804             SETs((SV*)hv);
 805             RETURN;
 806         }
 807         else if (LVRET) {
 808             if (GIMME == G_SCALAR)
 809                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 810             SETs((SV*)hv);
 811             RETURN;
 812         }
 813     }
 814     else {
 815         if (SvTYPE(sv) == SVt_PVHV) {
 816             hv = (HV*)sv;
 817             if (PL_op->op_flags & OPf_REF) {
 818                 SETs((SV*)hv);
 819                 RETURN;
 820             }
 821             else if (LVRET) {
 822                 if (GIMME == G_SCALAR)
 823                     Perl_croak(aTHX_ "Can't return hash to lvalue"
 824                                " scalar context");
 825                 SETs((SV*)hv);
 826                 RETURN;
 827             }
 828         }
 829         else {
 830             GV *gv;
 831
 832             if (SvTYPE(sv) != SVt_PVGV) {
 833                 char *sym;
 834                 STRLEN len;
 835
 836                 if (SvGMAGICAL(sv)) {
 837                     mg_get(sv);
 838                     if (SvROK(sv))
 839                         goto wasref;
 840                 }
 841                 if (!SvOK(sv)) {
 842                     if (PL_op->op_flags & OPf_REF ||
 843                       PL_op->op_private & HINT_STRICT_REFS)
 844                         DIE(aTHX_ PL_no_usym, "a HASH");
 845                     if (ckWARN(WARN_UNINITIALIZED))
 846                         report_uninit();
 847                     if (GIMME == G_ARRAY) {
 848                         SP--;
 849                         RETURN;
 850                     }
 851                     RETSETUNDEF;
 852                 }
 853                 sym = SvPV(sv,len);
 854                 if ((PL_op->op_flags & OPf_SPECIAL) &&
 855                     !(PL_op->op_flags & OPf_MOD))
 856                 {
 857                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
 858                     if (!gv
 859                         && (!is_gv_magical(sym,len,0)
 860                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
 861                     {
 862                         RETSETUNDEF;
 863                     }
 864                 }
 865                 else {
 866                     if (PL_op->op_private & HINT_STRICT_REFS)
 867                         DIE(aTHX_ PL_no_symref, sym, "a HASH");
 868                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
 869                 }
 870             }
 871             else {
 872                 gv = (GV*)sv;
 873             }
 874             hv = GvHVn(gv);
 875             if (PL_op->op_private & OPpLVAL_INTRO)
 876                 hv = save_hash(gv);
 877             if (PL_op->op_flags & OPf_REF) {
 878                 SETs((SV*)hv);
 879                 RETURN;
 880             }
 881             else if (LVRET) {
 882                 if (GIMME == G_SCALAR)
 883                     Perl_croak(aTHX_ "Can't return hash to lvalue"
 884                                " scalar context");
 885                 SETs((SV*)hv);
 886                 RETURN;
 887             }
 888         }
 889     }
 890
 891     if (GIMME == G_ARRAY) { /* array wanted */
 892         *PL_stack_sp = (SV*)hv;
 893         return do_kv();
 894     }
 895     else {
 896         dTARGET;
 897         if (HvFILL(hv))
 898             Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
 899                            (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
 900         else
 901             sv_setiv(TARG, 0);
 902
 903         SETTARG;
 904         RETURN;
 905     }
 906 }
 907
 908 STATIC void
 909 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 910 {
 911     if (*relem) {
 912         SV *tmpstr;
 913         HE *didstore;
 914
 915         if (ckWARN(WARN_MISC)) {
 916             if (relem == firstrelem &&
 917                 SvROK(*relem) &&
 918                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 919                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
 920             {
 921                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 922                             "Reference found where even-sized list expected");
 923             }
 924             else
 925                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 926                             "Odd number of elements in hash assignment");
 927         }
 928
 929         tmpstr = NEWSV(29,0);
 930         didstore = hv_store_ent(hash,*relem,tmpstr,0);
 931         if (SvMAGICAL(hash)) {
 932             if (SvSMAGICAL(tmpstr))
 933                 mg_set(tmpstr);
 934             if (!didstore)
 935                 sv_2mortal(tmpstr);
 936         }
 937         TAINT_NOT;
 938     }
 939 }
 940
 941 PP(pp_aassign)
 942 {
 943     dSP;
 944     SV **lastlelem = PL_stack_sp;
 945     SV **lastrelem = PL_stack_base + POPMARK;
 946     SV **firstrelem = PL_stack_base + POPMARK + 1;
 947     SV **firstlelem = lastrelem + 1;
 948
 949     register SV **relem;
 950     register SV **lelem;
 951
 952     register SV *sv;
 953     register AV *ary;
 954
 955     I32 gimme;
 956     HV *hash;
 957     I32 i;
 958     int magic;
 959
 960     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
 961
 962     /* If there's a common identifier on both sides we have to take
 963      * special care that assigning the identifier on the left doesn't
 964      * clobber a value on the right that's used later in the list.
 965      */
 966     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
 967         EXTEND_MORTAL(lastrelem - firstrelem + 1);
 968         for (relem = firstrelem; relem <= lastrelem; relem++) {
 969             /*SUPPRESS 560*/
 970             if ((sv = *relem)) {
 971                 TAINT_NOT;      /* Each item is independent */
 972                 *relem = sv_mortalcopy(sv);
 973             }
 974         }
 975     }
 976
 977     relem = firstrelem;
 978     lelem = firstlelem;
 979     ary = Null(AV*);
 980     hash = Null(HV*);
 981
 982     while (lelem <= lastlelem) {
 983         TAINT_NOT;              /* Each item stands on its own, taintwise. */
 984         sv = *lelem++;
 985         switch (SvTYPE(sv)) {
 986         case SVt_PVAV:
 987             ary = (AV*)sv;
 988             magic = SvMAGICAL(ary) != 0;
 989             av_clear(ary);
 990             av_extend(ary, lastrelem - relem);
 991             i = 0;
 992             while (relem <= lastrelem) {        /* gobble up all the rest */
 993                 SV **didstore;
 994                 sv = NEWSV(28,0);
 995                 assert(*relem);
 996                 sv_setsv(sv,*relem);
 997                 *(relem++) = sv;
 998                 didstore = av_store(ary,i++,sv);
 999                 if (magic) {
1000                     if (SvSMAGICAL(sv))
1001                         mg_set(sv);
1002                     if (!didstore)
1003                         sv_2mortal(sv);
1004                 }
1005                 TAINT_NOT;
1006             }
1007             break;
1008         case SVt_PVHV: {                                /* normal hash */
1009                 SV *tmpstr;
1010
1011                 hash = (HV*)sv;
1012                 magic = SvMAGICAL(hash) != 0;
1013                 hv_clear(hash);
1014
1015                 while (relem < lastrelem) {     /* gobble up all the rest */
1016                     HE *didstore;
1017                     if (*relem)
1018                         sv = *(relem++);
1019                     else
1020                         sv = &PL_sv_no, relem++;
1021                     tmpstr = NEWSV(29,0);
1022                     if (*relem)
1023                         sv_setsv(tmpstr,*relem);        /* value */
1024                     *(relem++) = tmpstr;
1025                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1026                     if (magic) {
1027                         if (SvSMAGICAL(tmpstr))
1028                             mg_set(tmpstr);
1029                         if (!didstore)
1030                             sv_2mortal(tmpstr);
1031                     }
1032                     TAINT_NOT;
1033                 }
1034                 if (relem == lastrelem) {
1035                     do_oddball(hash, relem, firstrelem);
1036                     relem++;
1037                 }
1038             }
1039             break;
1040         default:
1041             if (SvIMMORTAL(sv)) {
1042                 if (relem <= lastrelem)
1043                     relem++;
1044                 break;
1045             }
1046             if (relem <= lastrelem) {
1047                 sv_setsv(sv, *relem);
1048                 *(relem++) = sv;
1049             }
1050             else
1051                 sv_setsv(sv, &PL_sv_undef);
1052             SvSETMAGIC(sv);
1053             break;
1054         }
1055     }
1056     if (PL_delaymagic & ~DM_DELAY) {
1057         if (PL_delaymagic & DM_UID) {
1058 #ifdef HAS_SETRESUID
1059             (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
1060 #else
1061 #  ifdef HAS_SETREUID
1062             (void)setreuid(PL_uid,PL_euid);
1063 #  else
1064 #    ifdef HAS_SETRUID
1065             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1066                 (void)setruid(PL_uid);
1067                 PL_delaymagic &= ~DM_RUID;
1068             }
1069 #    endif /* HAS_SETRUID */
1070 #    ifdef HAS_SETEUID
1071             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1072                 (void)seteuid(PL_uid);
1073                 PL_delaymagic &= ~DM_EUID;
1074             }
1075 #    endif /* HAS_SETEUID */
1076             if (PL_delaymagic & DM_UID) {
1077                 if (PL_uid != PL_euid)
1078                     DIE(aTHX_ "No setreuid available");
1079                 (void)PerlProc_setuid(PL_uid);
1080             }
1081 #  endif /* HAS_SETREUID */
1082 #endif /* HAS_SETRESUID */
1083             PL_uid = PerlProc_getuid();
1084             PL_euid = PerlProc_geteuid();
1085         }
1086         if (PL_delaymagic & DM_GID) {
1087 #ifdef HAS_SETRESGID
1088             (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
1089 #else
1090 #  ifdef HAS_SETREGID
1091             (void)setregid(PL_gid,PL_egid);
1092 #  else
1093 #    ifdef HAS_SETRGID
1094             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1095                 (void)setrgid(PL_gid);
1096                 PL_delaymagic &= ~DM_RGID;
1097             }
1098 #    endif /* HAS_SETRGID */
1099 #    ifdef HAS_SETEGID
1100             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1101                 (void)setegid(PL_gid);
1102                 PL_delaymagic &= ~DM_EGID;
1103             }
1104 #    endif /* HAS_SETEGID */
1105             if (PL_delaymagic & DM_GID) {
1106                 if (PL_gid != PL_egid)
1107                     DIE(aTHX_ "No setregid available");
1108                 (void)PerlProc_setgid(PL_gid);
1109             }
1110 #  endif /* HAS_SETREGID */
1111 #endif /* HAS_SETRESGID */
1112             PL_gid = PerlProc_getgid();
1113             PL_egid = PerlProc_getegid();
1114         }
1115         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1116     }
1117     PL_delaymagic = 0;
1118
1119     gimme = GIMME_V;
1120     if (gimme == G_VOID)
1121         SP = firstrelem - 1;
1122     else if (gimme == G_SCALAR) {
1123         dTARGET;
1124         SP = firstrelem;
1125         SETi(lastrelem - firstrelem + 1);
1126     }
1127     else {
1128         if (ary || hash)
1129             SP = lastrelem;
1130         else
1131             SP = firstrelem + (lastlelem - firstlelem);
1132         lelem = firstlelem + (relem - firstrelem);
1133         while (relem <= SP)
1134             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1135     }
1136     RETURN;
1137 }
1138
1139 PP(pp_qr)
1140 {
1141     dSP;
1142     register PMOP *pm = cPMOP;
1143     SV *rv = sv_newmortal();
1144     SV *sv = newSVrv(rv, "Regexp");
1145     if (pm->op_pmdynflags & PMdf_TAINTED)
1146         SvTAINTED_on(rv);
1147     sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1148     RETURNX(PUSHs(rv));
1149 }
1150
1151 PP(pp_match)
1152 {
1153     dSP; dTARG;
1154     register PMOP *pm = cPMOP;
1155     PMOP *dynpm = pm;
1156     register char *t;
1157     register char *s;
1158     char *strend;
1159     I32 global;
1160     I32 r_flags = REXEC_CHECKED;
1161     char *truebase;                     /* Start of string  */
1162     register REGEXP *rx = PM_GETRE(pm);
1163     bool rxtainted;
1164     I32 gimme = GIMME;
1165     STRLEN len;
1166     I32 minmatch = 0;
1167     I32 oldsave = PL_savestack_ix;
1168     I32 update_minmatch = 1;
1169     I32 had_zerolen = 0;
1170
1171     if (PL_op->op_flags & OPf_STACKED)
1172         TARG = POPs;
1173     else {
1174         TARG = DEFSV;
1175         EXTEND(SP,1);
1176     }
1177
1178     PUTBACK;                            /* EVAL blocks need stack_sp. */
1179     s = SvPV(TARG, len);
1180     strend = s + len;
1181     if (!s)
1182         DIE(aTHX_ "panic: pp_match");
1183     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1184                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1185     TAINT_NOT;
1186
1187     PL_reg_match_utf8 = DO_UTF8(TARG);
1188
1189     /* PMdf_USED is set after a ?? matches once */
1190     if (pm->op_pmdynflags & PMdf_USED) {
1191       failure:
1192         if (gimme == G_ARRAY)
1193             RETURN;
1194         RETPUSHNO;
1195     }
1196
1197     /* empty pattern special-cased to use last successful pattern if possible */
1198     if (!rx->prelen && PL_curpm) {
1199         pm = PL_curpm;
1200         rx = PM_GETRE(pm);
1201     }
1202
1203     if (rx->minlen > (I32)len)
1204         goto failure;
1205
1206     truebase = t = s;
1207
1208     /* XXXX What part of this is needed with true \G-support? */
1209     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1210         rx->startp[0] = -1;
1211         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1212             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1213             if (mg && mg->mg_len >= 0) {
1214                 if (!(rx->reganch & ROPT_GPOS_SEEN))
1215                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1216                 else if (rx->reganch & ROPT_ANCH_GPOS) {
1217                     r_flags |= REXEC_IGNOREPOS;
1218                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1219                 }
1220                 minmatch = (mg->mg_flags & MGf_MINMATCH);
1221                 update_minmatch = 0;
1222             }
1223         }
1224     }
1225     if ((!global && rx->nparens)
1226             || SvTEMP(TARG) || PL_sawampersand)
1227         r_flags |= REXEC_COPY_STR;
1228     if (SvSCREAM(TARG))
1229         r_flags |= REXEC_SCREAM;
1230
1231     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1232         SAVEINT(PL_multiline);
1233         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1234     }
1235
1236 play_it_again:
1237     if (global && rx->startp[0] != -1) {
1238         t = s = rx->endp[0] + truebase;
1239         if ((s + rx->minlen) > strend)
1240             goto nope;
1241         if (update_minmatch++)
1242             minmatch = had_zerolen;
1243     }
1244     if (rx->reganch & RE_USE_INTUIT &&
1245         DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1246         PL_bostr = truebase;
1247         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1248
1249         if (!s)
1250             goto nope;
1251         if ( (rx->reganch & ROPT_CHECK_ALL)
1252              && !PL_sawampersand
1253              && ((rx->reganch & ROPT_NOSCAN)
1254                  || !((rx->reganch & RE_INTUIT_TAIL)
1255                       && (r_flags & REXEC_SCREAM)))
1256              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1257             goto yup;
1258     }
1259     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1260     {
1261         PL_curpm = pm;
1262         if (dynpm->op_pmflags & PMf_ONCE)
1263             dynpm->op_pmdynflags |= PMdf_USED;
1264         goto gotcha;
1265     }
1266     else
1267         goto ret_no;
1268     /*NOTREACHED*/
1269
1270   gotcha:
1271     if (rxtainted)
1272         RX_MATCH_TAINTED_on(rx);
1273     TAINT_IF(RX_MATCH_TAINTED(rx));
1274     if (gimme == G_ARRAY) {
1275         I32 nparens, i, len;
1276
1277         nparens = rx->nparens;
1278         if (global && !nparens)
1279             i = 1;
1280         else
1281             i = 0;
1282         SPAGAIN;                        /* EVAL blocks could move the stack. */
1283         EXTEND(SP, nparens + i);
1284         EXTEND_MORTAL(nparens + i);
1285         for (i = !i; i <= nparens; i++) {
1286             PUSHs(sv_newmortal());
1287             /*SUPPRESS 560*/
1288             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1289                 len = rx->endp[i] - rx->startp[i];
1290                 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1291                     len < 0 || len > strend - s)
1292                     DIE(aTHX_ "panic: pp_match start/end pointers");
1293                 s = rx->startp[i] + truebase;
1294                 sv_setpvn(*SP, s, len);
1295                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1296                     SvUTF8_on(*SP);
1297             }
1298         }
1299         if (global) {
1300             if (dynpm->op_pmflags & PMf_CONTINUE) {
1301                 MAGIC* mg = 0;
1302                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1303                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1304                 if (!mg) {
1305                     sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1306                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1307                 }
1308                 if (rx->startp[0] != -1) {
1309                     mg->mg_len = rx->endp[0];
1310                     if (rx->startp[0] == rx->endp[0])
1311                         mg->mg_flags |= MGf_MINMATCH;
1312                     else
1313                         mg->mg_flags &= ~MGf_MINMATCH;
1314                 }
1315             }
1316             had_zerolen = (rx->startp[0] != -1
1317                            && rx->startp[0] == rx->endp[0]);
1318             PUTBACK;                    /* EVAL blocks may use stack */
1319             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1320             goto play_it_again;
1321         }
1322         else if (!nparens)
1323             XPUSHs(&PL_sv_yes);
1324         LEAVE_SCOPE(oldsave);
1325         RETURN;
1326     }
1327     else {
1328         if (global) {
1329             MAGIC* mg = 0;
1330             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1331                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1332             if (!mg) {
1333                 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1334                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1335             }
1336             if (rx->startp[0] != -1) {
1337                 mg->mg_len = rx->endp[0];
1338                 if (rx->startp[0] == rx->endp[0])
1339                     mg->mg_flags |= MGf_MINMATCH;
1340                 else
1341                     mg->mg_flags &= ~MGf_MINMATCH;
1342             }
1343         }
1344         LEAVE_SCOPE(oldsave);
1345         RETPUSHYES;
1346     }
1347
1348 yup:                                    /* Confirmed by INTUIT */
1349     if (rxtainted)
1350         RX_MATCH_TAINTED_on(rx);
1351     TAINT_IF(RX_MATCH_TAINTED(rx));
1352     PL_curpm = pm;
1353     if (dynpm->op_pmflags & PMf_ONCE)
1354         dynpm->op_pmdynflags |= PMdf_USED;
1355     if (RX_MATCH_COPIED(rx))
1356         Safefree(rx->subbeg);
1357     RX_MATCH_COPIED_off(rx);
1358     rx->subbeg = Nullch;
1359     if (global) {
1360         rx->subbeg = truebase;
1361         rx->startp[0] = s - truebase;
1362         if (PL_reg_match_utf8) {
1363             char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1364             rx->endp[0] = t - truebase;
1365         }
1366         else {
1367             rx->endp[0] = s - truebase + rx->minlen;
1368         }
1369         rx->sublen = strend - truebase;
1370         goto gotcha;
1371     }
1372     if (PL_sawampersand) {
1373         I32 off;
1374
1375         rx->subbeg = savepvn(t, strend - t);
1376         rx->sublen = strend - t;
1377         RX_MATCH_COPIED_on(rx);
1378         off = rx->startp[0] = s - t;
1379         rx->endp[0] = off + rx->minlen;
1380     }
1381     else {                      /* startp/endp are used by @- @+. */
1382         rx->startp[0] = s - truebase;
1383         rx->endp[0] = s - truebase + rx->minlen;
1384     }
1385     rx->nparens = rx->lastparen = 0;    /* used by @- and @+ */
1386     LEAVE_SCOPE(oldsave);
1387     RETPUSHYES;
1388
1389 nope:
1390 ret_no:
1391     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1392         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1393             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1394             if (mg)
1395                 mg->mg_len = -1;
1396         }
1397     }
1398     LEAVE_SCOPE(oldsave);
1399     if (gimme == G_ARRAY)
1400         RETURN;
1401     RETPUSHNO;
1402 }
1403
1404 OP *
1405 Perl_do_readline(pTHX)
1406 {
1407     dSP; dTARGETSTACKED;
1408     register SV *sv;
1409     STRLEN tmplen = 0;
1410     STRLEN offset;
1411     PerlIO *fp;
1412     register IO *io = GvIO(PL_last_in_gv);
1413     register I32 type = PL_op->op_type;
1414     I32 gimme = GIMME_V;
1415     MAGIC *mg;
1416
1417     if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1418         PUSHMARK(SP);
1419         XPUSHs(SvTIED_obj((SV*)io, mg));
1420         PUTBACK;
1421         ENTER;
1422         call_method("READLINE", gimme);
1423         LEAVE;
1424         SPAGAIN;
1425         if (gimme == G_SCALAR) {
1426             SV* result = POPs;
1427             SvSetSV_nosteal(TARG, result);
1428             PUSHTARG;
1429         }
1430         RETURN;
1431     }
1432     fp = Nullfp;
1433     if (io) {
1434         fp = IoIFP(io);
1435         if (!fp) {
1436             if (IoFLAGS(io) & IOf_ARGV) {
1437                 if (IoFLAGS(io) & IOf_START) {
1438                     IoLINES(io) = 0;
1439                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1440                         IoFLAGS(io) &= ~IOf_START;
1441                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1442                         sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1443                         SvSETMAGIC(GvSV(PL_last_in_gv));
1444                         fp = IoIFP(io);
1445                         goto have_fp;
1446                     }
1447                 }
1448                 fp = nextargv(PL_last_in_gv);
1449                 if (!fp) { /* Note: fp != IoIFP(io) */
1450                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1451                 }
1452             }
1453             else if (type == OP_GLOB)
1454                 fp = Perl_start_glob(aTHX_ POPs, io);
1455         }
1456         else if (type == OP_GLOB)
1457             SP--;
1458         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1459             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1460         }
1461     }
1462     if (!fp) {
1463         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1464                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1465             if (type == OP_GLOB)
1466                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1467                             "glob failed (can't start child: %s)",
1468                             Strerror(errno));
1469             else
1470                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1471         }
1472         if (gimme == G_SCALAR) {
1473             (void)SvOK_off(TARG);
1474             PUSHTARG;
1475         }
1476         RETURN;
1477     }
1478   have_fp:
1479     if (gimme == G_SCALAR) {
1480         sv = TARG;
1481         if (SvROK(sv))
1482             sv_unref(sv);
1483         (void)SvUPGRADE(sv, SVt_PV);
1484         tmplen = SvLEN(sv);     /* remember if already alloced */
1485         if (!tmplen)
1486             Sv_Grow(sv, 80);    /* try short-buffering it */
1487         if (type == OP_RCATLINE)
1488             offset = SvCUR(sv);
1489         else
1490             offset = 0;
1491     }
1492     else {
1493         sv = sv_2mortal(NEWSV(57, 80));
1494         offset = 0;
1495     }
1496
1497     /* This should not be marked tainted if the fp is marked clean */
1498 #define MAYBE_TAINT_LINE(io, sv) \
1499     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1500         TAINT;                          \
1501         SvTAINTED_on(sv);               \
1502     }
1503
1504 /* delay EOF state for a snarfed empty file */
1505 #define SNARF_EOF(gimme,rs,io,sv) \
1506     (gimme != G_SCALAR || SvCUR(sv)                                     \
1507      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1508
1509     for (;;) {
1510         PUTBACK;
1511         if (!sv_gets(sv, fp, offset)
1512             && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1513         {
1514             PerlIO_clearerr(fp);
1515             if (IoFLAGS(io) & IOf_ARGV) {
1516                 fp = nextargv(PL_last_in_gv);
1517                 if (fp)
1518                     continue;
1519                 (void)do_close(PL_last_in_gv, FALSE);
1520             }
1521             else if (type == OP_GLOB) {
1522                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1523                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1524                            "glob failed (child exited with status %d%s)",
1525                            (int)(STATUS_CURRENT >> 8),
1526                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1527                 }
1528             }
1529             if (gimme == G_SCALAR) {
1530                 (void)SvOK_off(TARG);
1531                 SPAGAIN;
1532                 PUSHTARG;
1533             }
1534             MAYBE_TAINT_LINE(io, sv);
1535             RETURN;
1536         }
1537         MAYBE_TAINT_LINE(io, sv);
1538         IoLINES(io)++;
1539         IoFLAGS(io) |= IOf_NOLINE;
1540         SvSETMAGIC(sv);
1541         SPAGAIN;
1542         XPUSHs(sv);
1543         if (type == OP_GLOB) {
1544             char *tmps;
1545
1546             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1547                 tmps = SvEND(sv) - 1;
1548                 if (*tmps == *SvPVX(PL_rs)) {
1549                     *tmps = '\0';
1550                     SvCUR(sv)--;
1551                 }
1552             }
1553             for (tmps = SvPVX(sv); *tmps; tmps++)
1554                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1555                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1556                         break;
1557             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1558                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1559                 continue;
1560             }
1561         }
1562         if (gimme == G_ARRAY) {
1563             if (SvLEN(sv) - SvCUR(sv) > 20) {
1564                 SvLEN_set(sv, SvCUR(sv)+1);
1565                 Renew(SvPVX(sv), SvLEN(sv), char);
1566             }
1567             sv = sv_2mortal(NEWSV(58, 80));
1568             continue;
1569         }
1570         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1571             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1572             if (SvCUR(sv) < 60)
1573                 SvLEN_set(sv, 80);
1574             else
1575                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1576             Renew(SvPVX(sv), SvLEN(sv), char);
1577         }
1578         RETURN;
1579     }
1580 }
1581
1582 PP(pp_enter)
1583 {
1584     dSP;
1585     register PERL_CONTEXT *cx;
1586     I32 gimme = OP_GIMME(PL_op, -1);
1587
1588     if (gimme == -1) {
1589         if (cxstack_ix >= 0)
1590             gimme = cxstack[cxstack_ix].blk_gimme;
1591         else
1592             gimme = G_SCALAR;
1593     }
1594
1595     ENTER;
1596
1597     SAVETMPS;
1598     PUSHBLOCK(cx, CXt_BLOCK, SP);
1599
1600     RETURN;
1601 }
1602
1603 PP(pp_helem)
1604 {
1605     dSP;
1606     HE* he;
1607     SV **svp;
1608     SV *keysv = POPs;
1609     HV *hv = (HV*)POPs;
1610     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1611     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1612     SV *sv;
1613     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1614     I32 preeminent = 0;
1615
1616     if (SvTYPE(hv) == SVt_PVHV) {
1617         if (PL_op->op_private & OPpLVAL_INTRO) {
1618             MAGIC *mg;
1619             HV *stash;
1620             /* does the element we're localizing already exist? */
1621             preeminent =
1622                 /* can we determine whether it exists? */
1623                 (    !SvRMAGICAL(hv)
1624                   || mg_find((SV*)hv, PERL_MAGIC_env)
1625                   || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1626                         /* Try to preserve the existenceness of a tied hash
1627                          * element by using EXISTS and DELETE if possible.
1628                          * Fallback to FETCH and STORE otherwise */
1629                         && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1630                         && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1631                         && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1632                     )
1633                 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1634
1635         }
1636         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1637         svp = he ? &HeVAL(he) : 0;
1638     }
1639     else {
1640         RETPUSHUNDEF;
1641     }
1642     if (lval) {
1643         if (!svp || *svp == &PL_sv_undef) {
1644             SV* lv;
1645             SV* key2;
1646             if (!defer) {
1647                 STRLEN n_a;
1648                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1649             }
1650             lv = sv_newmortal();
1651             sv_upgrade(lv, SVt_PVLV);
1652             LvTYPE(lv) = 'y';
1653             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1654             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1655             LvTARG(lv) = SvREFCNT_inc(hv);
1656             LvTARGLEN(lv) = 1;
1657             PUSHs(lv);
1658             RETURN;
1659         }
1660         if (PL_op->op_private & OPpLVAL_INTRO) {
1661             if (HvNAME(hv) && isGV(*svp))
1662                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1663             else {
1664                 if (!preeminent) {
1665                     STRLEN keylen;
1666                     char *key = SvPV(keysv, keylen);
1667                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1668                 } else
1669                     save_helem(hv, keysv, svp);
1670             }
1671         }
1672         else if (PL_op->op_private & OPpDEREF)
1673             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1674     }
1675     sv = (svp ? *svp : &PL_sv_undef);
1676     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1677      * Pushing the magical RHS on to the stack is useless, since
1678      * that magic is soon destined to be misled by the local(),
1679      * and thus the later pp_sassign() will fail to mg_get() the
1680      * old value.  This should also cure problems with delayed
1681      * mg_get()s.  GSAR 98-07-03 */
1682     if (!lval && SvGMAGICAL(sv))
1683         sv = sv_mortalcopy(sv);
1684     PUSHs(sv);
1685     RETURN;
1686 }
1687
1688 PP(pp_leave)
1689 {
1690     dSP;
1691     register PERL_CONTEXT *cx;
1692     register SV **mark;
1693     SV **newsp;
1694     PMOP *newpm;
1695     I32 gimme;
1696
1697     if (PL_op->op_flags & OPf_SPECIAL) {
1698         cx = &cxstack[cxstack_ix];
1699         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1700     }
1701
1702     POPBLOCK(cx,newpm);
1703
1704     gimme = OP_GIMME(PL_op, -1);
1705     if (gimme == -1) {
1706         if (cxstack_ix >= 0)
1707             gimme = cxstack[cxstack_ix].blk_gimme;
1708         else
1709             gimme = G_SCALAR;
1710     }
1711
1712     TAINT_NOT;
1713     if (gimme == G_VOID)
1714         SP = newsp;
1715     else if (gimme == G_SCALAR) {
1716         MARK = newsp + 1;
1717         if (MARK <= SP) {
1718             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1719                 *MARK = TOPs;
1720             else
1721                 *MARK = sv_mortalcopy(TOPs);
1722         } else {
1723             MEXTEND(mark,0);
1724             *MARK = &PL_sv_undef;
1725         }
1726         SP = MARK;
1727     }
1728     else if (gimme == G_ARRAY) {
1729         /* in case LEAVE wipes old return values */
1730         for (mark = newsp + 1; mark <= SP; mark++) {
1731             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1732                 *mark = sv_mortalcopy(*mark);
1733                 TAINT_NOT;      /* Each item is independent */
1734             }
1735         }
1736     }
1737     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1738
1739     LEAVE;
1740
1741     RETURN;
1742 }
1743
1744 PP(pp_iter)
1745 {
1746     dSP;
1747     register PERL_CONTEXT *cx;
1748     SV* sv;
1749     AV* av;
1750     SV **itersvp;
1751
1752     EXTEND(SP, 1);
1753     cx = &cxstack[cxstack_ix];
1754     if (CxTYPE(cx) != CXt_LOOP)
1755         DIE(aTHX_ "panic: pp_iter");
1756
1757     itersvp = CxITERVAR(cx);
1758     av = cx->blk_loop.iterary;
1759     if (SvTYPE(av) != SVt_PVAV) {
1760         /* iterate ($min .. $max) */
1761         if (cx->blk_loop.iterlval) {
1762             /* string increment */
1763             register SV* cur = cx->blk_loop.iterlval;
1764             STRLEN maxlen;
1765             char *max = SvPV((SV*)av, maxlen);
1766             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1767 #ifndef USE_5005THREADS                   /* don't risk potential race */
1768                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1769                     /* safe to reuse old SV */
1770                     sv_setsv(*itersvp, cur);
1771                 }
1772                 else
1773 #endif
1774                 {
1775                     /* we need a fresh SV every time so that loop body sees a
1776                      * completely new SV for closures/references to work as
1777                      * they used to */
1778                     SvREFCNT_dec(*itersvp);
1779                     *itersvp = newSVsv(cur);
1780                 }
1781                 if (strEQ(SvPVX(cur), max))
1782                     sv_setiv(cur, 0); /* terminate next time */
1783                 else
1784                     sv_inc(cur);
1785                 RETPUSHYES;
1786             }
1787             RETPUSHNO;
1788         }
1789         /* integer increment */
1790         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1791             RETPUSHNO;
1792
1793 #ifndef USE_5005THREADS                   /* don't risk potential race */
1794         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1795             /* safe to reuse old SV */
1796             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1797         }
1798         else
1799 #endif
1800         {
1801             /* we need a fresh SV every time so that loop body sees a
1802              * completely new SV for closures/references to work as they
1803              * used to */
1804             SvREFCNT_dec(*itersvp);
1805             *itersvp = newSViv(cx->blk_loop.iterix++);
1806         }
1807         RETPUSHYES;
1808     }
1809
1810     /* iterate array */
1811     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1812         RETPUSHNO;
1813
1814     SvREFCNT_dec(*itersvp);
1815
1816     if (SvMAGICAL(av) || AvREIFY(av)) {
1817         SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1818         if (svp)
1819             sv = *svp;
1820         else
1821             sv = Nullsv;
1822     }
1823     else {
1824         sv = AvARRAY(av)[++cx->blk_loop.iterix];
1825     }
1826     if (sv)
1827         SvTEMP_off(sv);
1828     else
1829         sv = &PL_sv_undef;
1830     if (av != PL_curstack && sv == &PL_sv_undef) {
1831         SV *lv = cx->blk_loop.iterlval;
1832         if (lv && SvREFCNT(lv) > 1) {
1833             SvREFCNT_dec(lv);
1834             lv = Nullsv;
1835         }
1836         if (lv)
1837             SvREFCNT_dec(LvTARG(lv));
1838         else {
1839             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1840             sv_upgrade(lv, SVt_PVLV);
1841             LvTYPE(lv) = 'y';
1842             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1843         }
1844         LvTARG(lv) = SvREFCNT_inc(av);
1845         LvTARGOFF(lv) = cx->blk_loop.iterix;
1846         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1847         sv = (SV*)lv;
1848     }
1849
1850     *itersvp = SvREFCNT_inc(sv);
1851     RETPUSHYES;
1852 }
1853
1854 PP(pp_subst)
1855 {
1856     dSP; dTARG;
1857     register PMOP *pm = cPMOP;
1858     PMOP *rpm = pm;
1859     register SV *dstr;
1860     register char *s;
1861     char *strend;
1862     register char *m;
1863     char *c;
1864     register char *d;
1865     STRLEN clen;
1866     I32 iters = 0;
1867     I32 maxiters;
1868     register I32 i;
1869     bool once;
1870     bool rxtainted;
1871     char *orig;
1872     I32 r_flags;
1873     register REGEXP *rx = PM_GETRE(pm);
1874     STRLEN len;
1875     int force_on_match = 0;
1876     I32 oldsave = PL_savestack_ix;
1877     STRLEN slen;
1878     bool doutf8 = FALSE;
1879
1880     /* known replacement string? */
1881     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1882     if (PL_op->op_flags & OPf_STACKED)
1883         TARG = POPs;
1884     else {
1885         TARG = DEFSV;
1886         EXTEND(SP,1);
1887     }
1888
1889     if (SvFAKE(TARG) && SvREADONLY(TARG))
1890         sv_force_normal(TARG);
1891     if (SvREADONLY(TARG)
1892         || (SvTYPE(TARG) > SVt_PVLV
1893             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1894         DIE(aTHX_ PL_no_modify);
1895     PUTBACK;
1896
1897     s = SvPV(TARG, len);
1898     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1899         force_on_match = 1;
1900     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1901                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1902     if (PL_tainted)
1903         rxtainted |= 2;
1904     TAINT_NOT;
1905
1906     PL_reg_match_utf8 = DO_UTF8(TARG);
1907
1908   force_it:
1909     if (!pm || !s)
1910         DIE(aTHX_ "panic: pp_subst");
1911
1912     strend = s + len;
1913     slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1914     maxiters = 2 * slen + 10;   /* We can match twice at each
1915                                    position, once with zero-length,
1916                                    second time with non-zero. */
1917
1918     if (!rx->prelen && PL_curpm) {
1919         pm = PL_curpm;
1920         rx = PM_GETRE(pm);
1921     }
1922     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1923                 ? REXEC_COPY_STR : 0;
1924     if (SvSCREAM(TARG))
1925         r_flags |= REXEC_SCREAM;
1926     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1927         SAVEINT(PL_multiline);
1928         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1929     }
1930     orig = m = s;
1931     if (rx->reganch & RE_USE_INTUIT) {
1932         PL_bostr = orig;
1933         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1934
1935         if (!s)
1936             goto nope;
1937         /* How to do it in subst? */
1938 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
1939              && !PL_sawampersand
1940              && ((rx->reganch & ROPT_NOSCAN)
1941                  || !((rx->reganch & RE_INTUIT_TAIL)
1942                       && (r_flags & REXEC_SCREAM))))
1943             goto yup;
1944 */
1945     }
1946
1947     /* only replace once? */
1948     once = !(rpm->op_pmflags & PMf_GLOBAL);
1949
1950     /* known replacement string? */
1951     if (dstr) {
1952         /* replacement needing upgrading? */
1953         if (DO_UTF8(TARG) && !doutf8) {
1954              SV *nsv = sv_newmortal();
1955              SvSetSV(nsv, dstr);
1956              if (PL_encoding)
1957                   sv_recode_to_utf8(nsv, PL_encoding);
1958              else
1959                   sv_utf8_upgrade(nsv);
1960              c = SvPV(nsv, clen);
1961              doutf8 = TRUE;
1962         }
1963         else {
1964             c = SvPV(dstr, clen);
1965             doutf8 = DO_UTF8(dstr);
1966         }
1967     }
1968     else {
1969         c = Nullch;
1970         doutf8 = FALSE;
1971     }
1972
1973     /* can do inplace substitution? */
1974     if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1975         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1976         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1977                          r_flags | REXEC_CHECKED))
1978         {
1979             SPAGAIN;
1980             PUSHs(&PL_sv_no);
1981             LEAVE_SCOPE(oldsave);
1982             RETURN;
1983         }
1984         if (force_on_match) {
1985             force_on_match = 0;
1986             s = SvPV_force(TARG, len);
1987             goto force_it;
1988         }
1989         d = s;
1990         PL_curpm = pm;
1991         SvSCREAM_off(TARG);     /* disable possible screamer */
1992         if (once) {
1993             rxtainted |= RX_MATCH_TAINTED(rx);
1994             m = orig + rx->startp[0];
1995             d = orig + rx->endp[0];
1996             s = orig;
1997             if (m - s > strend - d) {  /* faster to shorten from end */
1998                 if (clen) {
1999                     Copy(c, m, clen, char);
2000                     m += clen;
2001                 }
2002                 i = strend - d;
2003                 if (i > 0) {
2004                     Move(d, m, i, char);
2005                     m += i;
2006                 }
2007                 *m = '\0';
2008                 SvCUR_set(TARG, m - s);
2009             }
2010             /*SUPPRESS 560*/
2011             else if ((i = m - s)) {     /* faster from front */
2012                 d -= clen;
2013                 m = d;
2014                 sv_chop(TARG, d-i);
2015                 s += i;
2016                 while (i--)
2017                     *--d = *--s;
2018                 if (clen)
2019                     Copy(c, m, clen, char);
2020             }
2021             else if (clen) {
2022                 d -= clen;
2023                 sv_chop(TARG, d);
2024                 Copy(c, d, clen, char);
2025             }
2026             else {
2027                 sv_chop(TARG, d);
2028             }
2029             TAINT_IF(rxtainted & 1);
2030             SPAGAIN;
2031             PUSHs(&PL_sv_yes);
2032         }
2033         else {
2034             do {
2035                 if (iters++ > maxiters)
2036                     DIE(aTHX_ "Substitution loop");
2037                 rxtainted |= RX_MATCH_TAINTED(rx);
2038                 m = rx->startp[0] + orig;
2039                 /*SUPPRESS 560*/
2040                 if ((i = m - s)) {
2041                     if (s != d)
2042                         Move(s, d, i, char);
2043                     d += i;
2044                 }
2045                 if (clen) {
2046                     Copy(c, d, clen, char);
2047                     d += clen;
2048                 }
2049                 s = rx->endp[0] + orig;
2050             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2051                                  TARG, NULL,
2052                                  /* don't match same null twice */
2053                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2054             if (s != d) {
2055                 i = strend - s;
2056                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2057                 Move(s, d, i+1, char);          /* include the NUL */
2058             }
2059             TAINT_IF(rxtainted & 1);
2060             SPAGAIN;
2061             PUSHs(sv_2mortal(newSViv((I32)iters)));
2062         }
2063         (void)SvPOK_only_UTF8(TARG);
2064         TAINT_IF(rxtainted);
2065         if (SvSMAGICAL(TARG)) {
2066             PUTBACK;
2067             mg_set(TARG);
2068             SPAGAIN;
2069         }
2070         SvTAINT(TARG);
2071         if (doutf8)
2072             SvUTF8_on(TARG);
2073         LEAVE_SCOPE(oldsave);
2074         RETURN;
2075     }
2076
2077     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2078                     r_flags | REXEC_CHECKED))
2079     {
2080         if (force_on_match) {
2081             force_on_match = 0;
2082             s = SvPV_force(TARG, len);
2083             goto force_it;
2084         }
2085         rxtainted |= RX_MATCH_TAINTED(rx);
2086         dstr = NEWSV(25, len);
2087         sv_setpvn(dstr, m, s-m);
2088         if (DO_UTF8(TARG))
2089             SvUTF8_on(dstr);
2090         PL_curpm = pm;
2091         if (!c) {
2092             register PERL_CONTEXT *cx;
2093             SPAGAIN;
2094             PUSHSUBST(cx);
2095             RETURNOP(cPMOP->op_pmreplroot);
2096         }
2097         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2098         do {
2099             if (iters++ > maxiters)
2100                 DIE(aTHX_ "Substitution loop");
2101             rxtainted |= RX_MATCH_TAINTED(rx);
2102             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2103                 m = s;
2104                 s = orig;
2105                 orig = rx->subbeg;
2106                 s = orig + (m - s);
2107                 strend = s + (strend - m);
2108             }
2109             m = rx->startp[0] + orig;
2110             sv_catpvn(dstr, s, m-s);
2111             s = rx->endp[0] + orig;
2112             if (clen)
2113                 sv_catpvn(dstr, c, clen);
2114             if (once)
2115                 break;
2116         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2117                              TARG, NULL, r_flags));
2118         if (doutf8 && !DO_UTF8(dstr)) {
2119             SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
2120
2121             sv_utf8_upgrade(nsv);
2122             sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
2123         }
2124         else
2125             sv_catpvn(dstr, s, strend - s);
2126
2127         (void)SvOOK_off(TARG);
2128         Safefree(SvPVX(TARG));
2129         SvPVX(TARG) = SvPVX(dstr);
2130         SvCUR_set(TARG, SvCUR(dstr));
2131         SvLEN_set(TARG, SvLEN(dstr));
2132         doutf8 |= DO_UTF8(dstr);
2133         SvPVX(dstr) = 0;
2134         sv_free(dstr);
2135
2136         TAINT_IF(rxtainted & 1);
2137         SPAGAIN;
2138         PUSHs(sv_2mortal(newSViv((I32)iters)));
2139
2140         (void)SvPOK_only(TARG);
2141         if (doutf8)
2142             SvUTF8_on(TARG);
2143         TAINT_IF(rxtainted);
2144         SvSETMAGIC(TARG);
2145         SvTAINT(TARG);
2146         LEAVE_SCOPE(oldsave);
2147         RETURN;
2148     }
2149     goto ret_no;
2150
2151 nope:
2152 ret_no:
2153     SPAGAIN;
2154     PUSHs(&PL_sv_no);
2155     LEAVE_SCOPE(oldsave);
2156     RETURN;
2157 }
2158
2159 PP(pp_grepwhile)
2160 {
2161     dSP;
2162
2163     if (SvTRUEx(POPs))
2164         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2165     ++*PL_markstack_ptr;
2166     LEAVE;                                      /* exit inner scope */
2167
2168     /* All done yet? */
2169     if (PL_stack_base + *PL_markstack_ptr > SP) {
2170         I32 items;
2171         I32 gimme = GIMME_V;
2172
2173         LEAVE;                                  /* exit outer scope */
2174         (void)POPMARK;                          /* pop src */
2175         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2176         (void)POPMARK;                          /* pop dst */
2177         SP = PL_stack_base + POPMARK;           /* pop original mark */
2178         if (gimme == G_SCALAR) {
2179             dTARGET;
2180             XPUSHi(items);
2181         }
2182         else if (gimme == G_ARRAY)
2183             SP += items;
2184         RETURN;
2185     }
2186     else {
2187         SV *src;
2188
2189         ENTER;                                  /* enter inner scope */
2190         SAVEVPTR(PL_curpm);
2191
2192         src = PL_stack_base[*PL_markstack_ptr];
2193         SvTEMP_off(src);
2194         DEFSV = src;
2195
2196         RETURNOP(cLOGOP->op_other);
2197     }
2198 }
2199
2200 PP(pp_leavesub)
2201 {
2202     dSP;
2203     SV **mark;
2204     SV **newsp;
2205     PMOP *newpm;
2206     I32 gimme;
2207     register PERL_CONTEXT *cx;
2208     SV *sv;
2209
2210     POPBLOCK(cx,newpm);
2211
2212     TAINT_NOT;
2213     if (gimme == G_SCALAR) {
2214         MARK = newsp + 1;
2215         if (MARK <= SP) {
2216             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2217                 if (SvTEMP(TOPs)) {
2218                     *MARK = SvREFCNT_inc(TOPs);
2219                     FREETMPS;
2220                     sv_2mortal(*MARK);
2221                 }
2222                 else {
2223                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2224                     FREETMPS;
2225                     *MARK = sv_mortalcopy(sv);
2226                     SvREFCNT_dec(sv);
2227                 }
2228             }
2229             else
2230                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2231         }
2232         else {
2233             MEXTEND(MARK, 0);
2234             *MARK = &PL_sv_undef;
2235         }
2236         SP = MARK;
2237     }
2238     else if (gimme == G_ARRAY) {
2239         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2240             if (!SvTEMP(*MARK)) {
2241                 *MARK = sv_mortalcopy(*MARK);
2242                 TAINT_NOT;      /* Each item is independent */
2243             }
2244         }
2245     }
2246     PUTBACK;
2247
2248     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2249     PL_curpm = newpm;   /* ... and pop $1 et al */
2250
2251     LEAVE;
2252     LEAVESUB(sv);
2253     return pop_return();
2254 }
2255
2256 /* This duplicates the above code because the above code must not
2257  * get any slower by more conditions */
2258 PP(pp_leavesublv)
2259 {
2260     dSP;
2261     SV **mark;
2262     SV **newsp;
2263     PMOP *newpm;
2264     I32 gimme;
2265     register PERL_CONTEXT *cx;
2266     SV *sv;
2267
2268     POPBLOCK(cx,newpm);
2269
2270     TAINT_NOT;
2271
2272     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2273         /* We are an argument to a function or grep().
2274          * This kind of lvalueness was legal before lvalue
2275          * subroutines too, so be backward compatible:
2276          * cannot report errors.  */
2277
2278         /* Scalar context *is* possible, on the LHS of -> only,
2279          * as in f()->meth().  But this is not an lvalue. */
2280         if (gimme == G_SCALAR)
2281             goto temporise;
2282         if (gimme == G_ARRAY) {
2283             if (!CvLVALUE(cx->blk_sub.cv))
2284                 goto temporise_array;
2285             EXTEND_MORTAL(SP - newsp);
2286             for (mark = newsp + 1; mark <= SP; mark++) {
2287                 if (SvTEMP(*mark))
2288                     /* empty */ ;
2289                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2290                     *mark = sv_mortalcopy(*mark);
2291                 else {
2292                     /* Can be a localized value subject to deletion. */
2293                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2294                     (void)SvREFCNT_inc(*mark);
2295                 }
2296             }
2297         }
2298     }
2299     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2300         /* Here we go for robustness, not for speed, so we change all
2301          * the refcounts so the caller gets a live guy. Cannot set
2302          * TEMP, so sv_2mortal is out of question. */
2303         if (!CvLVALUE(cx->blk_sub.cv)) {
2304             POPSUB(cx,sv);
2305             PL_curpm = newpm;
2306             LEAVE;
2307             LEAVESUB(sv);
2308             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2309         }
2310         if (gimme == G_SCALAR) {
2311             MARK = newsp + 1;
2312             EXTEND_MORTAL(1);
2313             if (MARK == SP) {
2314                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2315                     POPSUB(cx,sv);
2316                     PL_curpm = newpm;
2317                     LEAVE;
2318                     LEAVESUB(sv);
2319                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2320                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2321                 }
2322                 else {                  /* Can be a localized value
2323                                          * subject to deletion. */
2324                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2325                     (void)SvREFCNT_inc(*mark);
2326                 }
2327             }
2328             else {                      /* Should not happen? */
2329                 POPSUB(cx,sv);
2330                 PL_curpm = newpm;
2331                 LEAVE;
2332                 LEAVESUB(sv);
2333                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2334                     (MARK > SP ? "Empty array" : "Array"));
2335             }
2336             SP = MARK;
2337         }
2338         else if (gimme == G_ARRAY) {
2339             EXTEND_MORTAL(SP - newsp);
2340             for (mark = newsp + 1; mark <= SP; mark++) {
2341                 if (*mark != &PL_sv_undef
2342                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2343                     /* Might be flattened array after $#array =  */
2344                     PUTBACK;
2345                     POPSUB(cx,sv);
2346                     PL_curpm = newpm;
2347                     LEAVE;
2348                     LEAVESUB(sv);
2349                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2350                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2351                 }
2352                 else {
2353                     /* Can be a localized value subject to deletion. */
2354                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2355                     (void)SvREFCNT_inc(*mark);
2356                 }
2357             }
2358         }
2359     }
2360     else {
2361         if (gimme == G_SCALAR) {
2362           temporise:
2363             MARK = newsp + 1;
2364             if (MARK <= SP) {
2365                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2366                     if (SvTEMP(TOPs)) {
2367                         *MARK = SvREFCNT_inc(TOPs);
2368                         FREETMPS;
2369                         sv_2mortal(*MARK);
2370                     }
2371                     else {
2372                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2373                         FREETMPS;
2374                         *MARK = sv_mortalcopy(sv);
2375                         SvREFCNT_dec(sv);
2376                     }
2377                 }
2378                 else
2379                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2380             }
2381             else {
2382                 MEXTEND(MARK, 0);
2383                 *MARK = &PL_sv_undef;
2384             }
2385             SP = MARK;
2386         }
2387         else if (gimme == G_ARRAY) {
2388           temporise_array:
2389             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2390                 if (!SvTEMP(*MARK)) {
2391                     *MARK = sv_mortalcopy(*MARK);
2392                     TAINT_NOT;  /* Each item is independent */
2393                 }
2394             }
2395         }
2396     }
2397     PUTBACK;
2398
2399     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2400     PL_curpm = newpm;   /* ... and pop $1 et al */
2401
2402     LEAVE;
2403     LEAVESUB(sv);
2404     return pop_return();
2405 }
2406
2407
2408 STATIC CV *
2409 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2410 {
2411     SV *dbsv = GvSV(PL_DBsub);
2412
2413     if (!PERLDB_SUB_NN) {
2414         GV *gv = CvGV(cv);
2415
2416         save_item(dbsv);
2417         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2418              || strEQ(GvNAME(gv), "END")
2419              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2420                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2421                     && (gv = (GV*)*svp) ))) {
2422             /* Use GV from the stack as a fallback. */
2423             /* GV is potentially non-unique, or contain different CV. */
2424             SV *tmp = newRV((SV*)cv);
2425             sv_setsv(dbsv, tmp);
2426             SvREFCNT_dec(tmp);
2427         }
2428         else {
2429             gv_efullname3(dbsv, gv, Nullch);
2430         }
2431     }
2432     else {
2433         (void)SvUPGRADE(dbsv, SVt_PVIV);
2434         (void)SvIOK_on(dbsv);
2435         SAVEIV(SvIVX(dbsv));
2436         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2437     }
2438
2439     if (CvXSUB(cv))
2440         PL_curcopdb = PL_curcop;
2441     cv = GvCV(PL_DBsub);
2442     return cv;
2443 }
2444
2445 PP(pp_entersub)
2446 {
2447     dSP; dPOPss;
2448     GV *gv;
2449     HV *stash;
2450     register CV *cv;
2451     register PERL_CONTEXT *cx;
2452     I32 gimme;
2453     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2454
2455     if (!sv)
2456         DIE(aTHX_ "Not a CODE reference");
2457     switch (SvTYPE(sv)) {
2458     default:
2459         if (!SvROK(sv)) {
2460             char *sym;
2461             STRLEN n_a;
2462
2463             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2464                 if (hasargs)
2465                     SP = PL_stack_base + POPMARK;
2466                 RETURN;
2467             }
2468             if (SvGMAGICAL(sv)) {
2469                 mg_get(sv);
2470                 if (SvROK(sv))
2471                     goto got_rv;
2472                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2473             }
2474             else
2475                 sym = SvPV(sv, n_a);
2476             if (!sym)
2477                 DIE(aTHX_ PL_no_usym, "a subroutine");
2478             if (PL_op->op_private & HINT_STRICT_REFS)
2479                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2480             cv = get_cv(sym, TRUE);
2481             break;
2482         }
2483   got_rv:
2484         {
2485             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2486             tryAMAGICunDEREF(to_cv);
2487         }
2488         cv = (CV*)SvRV(sv);
2489         if (SvTYPE(cv) == SVt_PVCV)
2490             break;
2491         /* FALL THROUGH */
2492     case SVt_PVHV:
2493     case SVt_PVAV:
2494         DIE(aTHX_ "Not a CODE reference");
2495     case SVt_PVCV:
2496         cv = (CV*)sv;
2497         break;
2498     case SVt_PVGV:
2499         if (!(cv = GvCVu((GV*)sv)))
2500             cv = sv_2cv(sv, &stash, &gv, FALSE);
2501         if (!cv) {
2502             ENTER;
2503             SAVETMPS;
2504             goto try_autoload;
2505         }
2506         break;
2507     }
2508
2509     ENTER;
2510     SAVETMPS;
2511
2512   retry:
2513     if (!CvROOT(cv) && !CvXSUB(cv)) {
2514         GV* autogv;
2515         SV* sub_name;
2516
2517         /* anonymous or undef'd function leaves us no recourse */
2518         if (CvANON(cv) || !(gv = CvGV(cv)))
2519             DIE(aTHX_ "Undefined subroutine called");
2520
2521         /* autoloaded stub? */
2522         if (cv != GvCV(gv)) {
2523             cv = GvCV(gv);
2524         }
2525         /* should call AUTOLOAD now? */
2526         else {
2527 try_autoload:
2528             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2529                                    FALSE)))
2530             {
2531                 cv = GvCV(autogv);
2532             }
2533             /* sorry */
2534             else {
2535                 sub_name = sv_newmortal();
2536                 gv_efullname3(sub_name, gv, Nullch);
2537                 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2538             }
2539         }
2540         if (!cv)
2541             DIE(aTHX_ "Not a CODE reference");
2542         goto retry;
2543     }
2544
2545     gimme = GIMME_V;
2546     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2547         cv = get_db_sub(&sv, cv);
2548         if (!cv)
2549             DIE(aTHX_ "No DBsub routine");
2550     }
2551
2552 #ifdef USE_5005THREADS
2553     /*
2554      * First we need to check if the sub or method requires locking.
2555      * If so, we gain a lock on the CV, the first argument or the
2556      * stash (for static methods), as appropriate. This has to be
2557      * inline because for FAKE_THREADS, COND_WAIT inlines code to
2558      * reschedule by returning a new op.
2559      */
2560     MUTEX_LOCK(CvMUTEXP(cv));
2561     if (CvFLAGS(cv) & CVf_LOCKED) {
2562         MAGIC *mg;
2563         if (CvFLAGS(cv) & CVf_METHOD) {
2564             if (SP > PL_stack_base + TOPMARK)
2565                 sv = *(PL_stack_base + TOPMARK + 1);
2566             else {
2567                 AV *av = (AV*)PL_curpad[0];
2568                 if (hasargs || !av || AvFILLp(av) < 0
2569                     || !(sv = AvARRAY(av)[0]))
2570                 {
2571                     MUTEX_UNLOCK(CvMUTEXP(cv));
2572                     DIE(aTHX_ "no argument for locked method call");
2573                 }
2574             }
2575             if (SvROK(sv))
2576                 sv = SvRV(sv);
2577             else {
2578                 STRLEN len;
2579                 char *stashname = SvPV(sv, len);
2580                 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2581             }
2582         }
2583         else {
2584             sv = (SV*)cv;
2585         }
2586         MUTEX_UNLOCK(CvMUTEXP(cv));
2587         mg = condpair_magic(sv);
2588         MUTEX_LOCK(MgMUTEXP(mg));
2589         if (MgOWNER(mg) == thr)
2590             MUTEX_UNLOCK(MgMUTEXP(mg));
2591         else {
2592             while (MgOWNER(mg))
2593                 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2594             MgOWNER(mg) = thr;
2595             DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2596                                   thr, sv));
2597             MUTEX_UNLOCK(MgMUTEXP(mg));
2598             SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2599         }
2600         MUTEX_LOCK(CvMUTEXP(cv));
2601     }
2602     /*
2603      * Now we have permission to enter the sub, we must distinguish
2604      * four cases. (0) It's an XSUB (in which case we don't care
2605      * about ownership); (1) it's ours already (and we're recursing);
2606      * (2) it's free (but we may already be using a cached clone);
2607      * (3) another thread owns it. Case (1) is easy: we just use it.
2608      * Case (2) means we look for a clone--if we have one, use it
2609      * otherwise grab ownership of cv. Case (3) means we look for a
2610      * clone (for non-XSUBs) and have to create one if we don't
2611      * already have one.
2612      * Why look for a clone in case (2) when we could just grab
2613      * ownership of cv straight away? Well, we could be recursing,
2614      * i.e. we originally tried to enter cv while another thread
2615      * owned it (hence we used a clone) but it has been freed up
2616      * and we're now recursing into it. It may or may not be "better"
2617      * to use the clone but at least CvDEPTH can be trusted.
2618      */
2619     if (CvOWNER(cv) == thr || CvXSUB(cv))
2620         MUTEX_UNLOCK(CvMUTEXP(cv));
2621     else {
2622         /* Case (2) or (3) */
2623         SV **svp;
2624
2625         /*
2626          * XXX Might it be better to release CvMUTEXP(cv) while we
2627          * do the hv_fetch? We might find someone has pinched it
2628          * when we look again, in which case we would be in case
2629          * (3) instead of (2) so we'd have to clone. Would the fact
2630          * that we released the mutex more quickly make up for this?
2631          */
2632         if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2633         {
2634             /* We already have a clone to use */
2635             MUTEX_UNLOCK(CvMUTEXP(cv));
2636             cv = *(CV**)svp;
2637             DEBUG_S(PerlIO_printf(Perl_debug_log,
2638                                   "entersub: %p already has clone %p:%s\n",
2639                                   thr, cv, SvPEEK((SV*)cv)));
2640             CvOWNER(cv) = thr;
2641             SvREFCNT_inc(cv);
2642             if (CvDEPTH(cv) == 0)
2643                 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2644         }
2645         else {
2646             /* (2) => grab ownership of cv. (3) => make clone */
2647             if (!CvOWNER(cv)) {
2648                 CvOWNER(cv) = thr;
2649                 SvREFCNT_inc(cv);
2650                 MUTEX_UNLOCK(CvMUTEXP(cv));
2651                 DEBUG_S(PerlIO_printf(Perl_debug_log,
2652                             "entersub: %p grabbing %p:%s in stash %s\n",
2653                             thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2654                                 HvNAME(CvSTASH(cv)) : "(none)"));
2655             }
2656             else {
2657                 /* Make a new clone. */
2658                 CV *clonecv;
2659                 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2660                 MUTEX_UNLOCK(CvMUTEXP(cv));
2661                 DEBUG_S((PerlIO_printf(Perl_debug_log,
2662                                        "entersub: %p cloning %p:%s\n",
2663                                        thr, cv, SvPEEK((SV*)cv))));
2664                 /*
2665                  * We're creating a new clone so there's no race
2666                  * between the original MUTEX_UNLOCK and the
2667                  * SvREFCNT_inc since no one will be trying to undef
2668                  * it out from underneath us. At least, I don't think
2669                  * there's a race...
2670                  */
2671                 clonecv = cv_clone(cv);
2672                 SvREFCNT_dec(cv); /* finished with this */
2673                 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2674                 CvOWNER(clonecv) = thr;
2675                 cv = clonecv;
2676                 SvREFCNT_inc(cv);
2677             }
2678             DEBUG_S(if (CvDEPTH(cv) != 0)
2679                         PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2680                                      CvDEPTH(cv)));
2681             SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2682         }
2683     }
2684 #endif /* USE_5005THREADS */
2685
2686     if (CvXSUB(cv)) {
2687 #ifdef PERL_XSUB_OLDSTYLE
2688         if (CvOLDSTYLE(cv)) {
2689             I32 (*fp3)(int,int,int);
2690             dMARK;
2691             register I32 items = SP - MARK;
2692                                         /* We dont worry to copy from @_. */
2693             while (SP > mark) {
2694                 SP[1] = SP[0];
2695                 SP--;
2696             }
2697             PL_stack_sp = mark + 1;
2698             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2699             items = (*fp3)(CvXSUBANY(cv).any_i32,
2700                            MARK - PL_stack_base + 1,
2701                            items);
2702             PL_stack_sp = PL_stack_base + items;
2703         }
2704         else
2705 #endif /* PERL_XSUB_OLDSTYLE */
2706         {
2707             I32 markix = TOPMARK;
2708
2709             PUTBACK;
2710
2711             if (!hasargs) {
2712                 /* Need to copy @_ to stack. Alternative may be to
2713                  * switch stack to @_, and copy return values
2714                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2715                 AV* av;
2716                 I32 items;
2717 #ifdef USE_5005THREADS
2718                 av = (AV*)PL_curpad[0];
2719 #else
2720                 av = GvAV(PL_defgv);
2721 #endif /* USE_5005THREADS */
2722                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2723
2724                 if (items) {
2725                     /* Mark is at the end of the stack. */
2726                     EXTEND(SP, items);
2727                     Copy(AvARRAY(av), SP + 1, items, SV*);
2728                     SP += items;
2729                     PUTBACK ;
2730                 }
2731             }
2732             /* We assume first XSUB in &DB::sub is the called one. */
2733             if (PL_curcopdb) {
2734                 SAVEVPTR(PL_curcop);
2735                 PL_curcop = PL_curcopdb;
2736                 PL_curcopdb = NULL;
2737             }
2738             /* Do we need to open block here? XXXX */
2739             (void)(*CvXSUB(cv))(aTHX_ cv);
2740
2741             /* Enforce some sanity in scalar context. */
2742             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2743                 if (markix > PL_stack_sp - PL_stack_base)
2744                     *(PL_stack_base + markix) = &PL_sv_undef;
2745                 else
2746                     *(PL_stack_base + markix) = *PL_stack_sp;
2747                 PL_stack_sp = PL_stack_base + markix;
2748             }
2749         }
2750         LEAVE;
2751         return NORMAL;
2752     }
2753     else {
2754         dMARK;
2755         register I32 items = SP - MARK;
2756         AV* padlist = CvPADLIST(cv);
2757         SV** svp = AvARRAY(padlist);
2758         push_return(PL_op->op_next);
2759         PUSHBLOCK(cx, CXt_SUB, MARK);
2760         PUSHSUB(cx);
2761         CvDEPTH(cv)++;
2762         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2763          * that eval'' ops within this sub know the correct lexical space.
2764          * Owing the speed considerations, we choose to search for the cv
2765          * in doeval() instead.
2766          */
2767         if (CvDEPTH(cv) < 2)
2768             (void)SvREFCNT_inc(cv);
2769         else {  /* save temporaries on recursion? */
2770             PERL_STACK_OVERFLOW_CHECK();
2771             if (CvDEPTH(cv) > AvFILLp(padlist)) {
2772                 AV *av;
2773                 AV *newpad = newAV();
2774                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2775                 I32 ix = AvFILLp((AV*)svp[1]);
2776                 I32 names_fill = AvFILLp((AV*)svp[0]);
2777                 svp = AvARRAY(svp[0]);
2778                 for ( ;ix > 0; ix--) {
2779                     if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2780                         char *name = SvPVX(svp[ix]);
2781                         if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2782                             || *name == '&')              /* anonymous code? */
2783                         {
2784                             av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2785                         }
2786                         else {                          /* our own lexical */
2787                             if (*name == '@')
2788                                 av_store(newpad, ix, sv = (SV*)newAV());
2789                             else if (*name == '%')
2790                                 av_store(newpad, ix, sv = (SV*)newHV());
2791                             else
2792                                 av_store(newpad, ix, sv = NEWSV(0,0));
2793                             SvPADMY_on(sv);
2794                         }
2795                     }
2796                     else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2797                         av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2798                     }
2799                     else {
2800                         av_store(newpad, ix, sv = NEWSV(0,0));
2801                         SvPADTMP_on(sv);
2802                     }
2803                 }
2804                 av = newAV();           /* will be @_ */
2805                 av_extend(av, 0);
2806                 av_store(newpad, 0, (SV*)av);
2807                 AvFLAGS(av) = AVf_REIFY;
2808                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2809                 AvFILLp(padlist) = CvDEPTH(cv);
2810                 svp = AvARRAY(padlist);
2811             }
2812         }
2813 #ifdef USE_5005THREADS
2814         if (!hasargs) {
2815             AV* av = (AV*)PL_curpad[0];
2816
2817             items = AvFILLp(av) + 1;
2818             if (items) {
2819                 /* Mark is at the end of the stack. */
2820                 EXTEND(SP, items);
2821                 Copy(AvARRAY(av), SP + 1, items, SV*);
2822                 SP += items;
2823                 PUTBACK ;
2824             }
2825         }
2826 #endif /* USE_5005THREADS */
2827         SAVEVPTR(PL_curpad);
2828         PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2829 #ifndef USE_5005THREADS
2830         if (hasargs)
2831 #endif /* USE_5005THREADS */
2832         {
2833             AV* av;
2834             SV** ary;
2835
2836 #if 0
2837             DEBUG_S(PerlIO_printf(Perl_debug_log,
2838                                   "%p entersub preparing @_\n", thr));
2839 #endif
2840             av = (AV*)PL_curpad[0];
2841             if (AvREAL(av)) {
2842                 /* @_ is normally not REAL--this should only ever
2843                  * happen when DB::sub() calls things that modify @_ */
2844                 av_clear(av);
2845                 AvREAL_off(av);
2846                 AvREIFY_on(av);
2847             }
2848 #ifndef USE_5005THREADS
2849             cx->blk_sub.savearray = GvAV(PL_defgv);
2850             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2851 #endif /* USE_5005THREADS */
2852             cx->blk_sub.oldcurpad = PL_curpad;
2853             cx->blk_sub.argarray = av;
2854             ++MARK;
2855
2856             if (items > AvMAX(av) + 1) {
2857                 ary = AvALLOC(av);
2858                 if (AvARRAY(av) != ary) {
2859                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2860                     SvPVX(av) = (char*)ary;
2861                 }
2862                 if (items > AvMAX(av) + 1) {
2863                     AvMAX(av) = items - 1;
2864                     Renew(ary,items,SV*);
2865                     AvALLOC(av) = ary;
2866                     SvPVX(av) = (char*)ary;
2867                 }
2868             }
2869             Copy(MARK,AvARRAY(av),items,SV*);
2870             AvFILLp(av) = items - 1;
2871
2872             while (items--) {
2873                 if (*MARK)
2874                     SvTEMP_off(*MARK);
2875                 MARK++;
2876             }
2877         }
2878         /* warning must come *after* we fully set up the context
2879          * stuff so that __WARN__ handlers can safely dounwind()
2880          * if they want to
2881          */
2882         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2883             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2884             sub_crush_depth(cv);
2885 #if 0
2886         DEBUG_S(PerlIO_printf(Perl_debug_log,
2887                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2888 #endif
2889         RETURNOP(CvSTART(cv));
2890     }
2891 }
2892
2893 void
2894 Perl_sub_crush_depth(pTHX_ CV *cv)
2895 {
2896     if (CvANON(cv))
2897         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2898     else {
2899         SV* tmpstr = sv_newmortal();
2900         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2901         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
2902                 SvPVX(tmpstr));
2903     }
2904 }
2905
2906 PP(pp_aelem)
2907 {
2908     dSP;
2909     SV** svp;
2910     SV* elemsv = POPs;
2911     IV elem = SvIV(elemsv);
2912     AV* av = (AV*)POPs;
2913     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2914     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2915     SV *sv;
2916
2917     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2918         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2919     if (elem > 0)
2920         elem -= PL_curcop->cop_arybase;
2921     if (SvTYPE(av) != SVt_PVAV)
2922         RETPUSHUNDEF;
2923     svp = av_fetch(av, elem, lval && !defer);
2924     if (lval) {
2925         if (!svp || *svp == &PL_sv_undef) {
2926             SV* lv;
2927             if (!defer)
2928                 DIE(aTHX_ PL_no_aelem, elem);
2929             lv = sv_newmortal();
2930             sv_upgrade(lv, SVt_PVLV);
2931             LvTYPE(lv) = 'y';
2932             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2933             LvTARG(lv) = SvREFCNT_inc(av);
2934             LvTARGOFF(lv) = elem;
2935             LvTARGLEN(lv) = 1;
2936             PUSHs(lv);
2937             RETURN;
2938         }
2939         if (PL_op->op_private & OPpLVAL_INTRO)
2940             save_aelem(av, elem, svp);
2941         else if (PL_op->op_private & OPpDEREF)
2942             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2943     }
2944     sv = (svp ? *svp : &PL_sv_undef);
2945     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2946         sv = sv_mortalcopy(sv);
2947     PUSHs(sv);
2948     RETURN;
2949 }
2950
2951 void
2952 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2953 {
2954     if (SvGMAGICAL(sv))
2955         mg_get(sv);
2956     if (!SvOK(sv)) {
2957         if (SvREADONLY(sv))
2958             Perl_croak(aTHX_ PL_no_modify);
2959         if (SvTYPE(sv) < SVt_RV)
2960             sv_upgrade(sv, SVt_RV);
2961         else if (SvTYPE(sv) >= SVt_PV) {
2962             (void)SvOOK_off(sv);
2963             Safefree(SvPVX(sv));
2964             SvLEN(sv) = SvCUR(sv) = 0;
2965         }
2966         switch (to_what) {
2967         case OPpDEREF_SV:
2968             SvRV(sv) = NEWSV(355,0);
2969             break;
2970         case OPpDEREF_AV:
2971             SvRV(sv) = (SV*)newAV();
2972             break;
2973         case OPpDEREF_HV:
2974             SvRV(sv) = (SV*)newHV();
2975             break;
2976         }
2977         SvROK_on(sv);
2978         SvSETMAGIC(sv);
2979     }
2980 }
2981
2982 PP(pp_method)
2983 {
2984     dSP;
2985     SV* sv = TOPs;
2986
2987     if (SvROK(sv)) {
2988         SV* rsv = SvRV(sv);
2989         if (SvTYPE(rsv) == SVt_PVCV) {
2990             SETs(rsv);
2991             RETURN;
2992         }
2993     }
2994
2995     SETs(method_common(sv, Null(U32*)));
2996     RETURN;
2997 }
2998
2999 PP(pp_method_named)
3000 {
3001     dSP;
3002     SV* sv = cSVOP->op_sv;
3003     U32 hash = SvUVX(sv);
3004
3005     XPUSHs(method_common(sv, &hash));
3006     RETURN;
3007 }
3008
3009 STATIC SV *
3010 S_method_common(pTHX_ SV* meth, U32* hashp)
3011 {
3012     SV* sv;
3013     SV* ob;
3014     GV* gv;
3015     HV* stash;
3016     char* name;
3017     STRLEN namelen;
3018     char* packname = 0;
3019     STRLEN packlen;
3020
3021     name = SvPV(meth, namelen);
3022     sv = *(PL_stack_base + TOPMARK + 1);
3023
3024     if (!sv)
3025         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3026
3027     if (SvGMAGICAL(sv))
3028         mg_get(sv);
3029     if (SvROK(sv))
3030         ob = (SV*)SvRV(sv);
3031     else {
3032         GV* iogv;
3033
3034         /* this isn't a reference */
3035         packname = Nullch;
3036         if (!SvOK(sv) ||
3037             !(packname = SvPV(sv, packlen)) ||
3038             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3039             !(ob=(SV*)GvIO(iogv)))
3040         {
3041             /* this isn't the name of a filehandle either */
3042             if (!packname ||
3043                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3044                     ? !isIDFIRST_utf8((U8*)packname)
3045                     : !isIDFIRST(*packname)
3046                 ))
3047             {
3048                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3049                            SvOK(sv) ? "without a package or object reference"
3050                                     : "on an undefined value");
3051             }
3052             /* assume it's a package name */
3053             stash = gv_stashpvn(packname, packlen, FALSE);
3054             goto fetch;
3055         }
3056         /* it _is_ a filehandle name -- replace with a reference */
3057         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3058     }
3059
3060     /* if we got here, ob should be a reference or a glob */
3061     if (!ob || !(SvOBJECT(ob)
3062                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3063                      && SvOBJECT(ob))))
3064     {
3065         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3066                    name);
3067     }
3068
3069     stash = SvSTASH(ob);
3070
3071   fetch:
3072     /* NOTE: stash may be null, hope hv_fetch_ent and
3073        gv_fetchmethod can cope (it seems they can) */
3074
3075     /* shortcut for simple names */
3076     if (hashp) {
3077         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3078         if (he) {
3079             gv = (GV*)HeVAL(he);
3080             if (isGV(gv) && GvCV(gv) &&
3081                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3082                 return (SV*)GvCV(gv);
3083         }
3084     }
3085
3086     gv = gv_fetchmethod(stash, name);
3087
3088     if (!gv) {
3089         /* This code tries to figure out just what went wrong with
3090            gv_fetchmethod.  It therefore needs to duplicate a lot of
3091            the internals of that function.  We can't move it inside
3092            Perl_gv_fetchmethod_autoload(), however, since that would
3093            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3094            don't want that.
3095         */
3096         char* leaf = name;
3097         char* sep = Nullch;
3098         char* p;
3099
3100         for (p = name; *p; p++) {
3101             if (*p == '\'')
3102                 sep = p, leaf = p + 1;
3103             else if (*p == ':' && *(p + 1) == ':')
3104                 sep = p, leaf = p + 2;
3105         }
3106         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3107             /* the method name is unqualified or starts with SUPER:: */
3108             packname = sep ? CopSTASHPV(PL_curcop) :
3109                 stash ? HvNAME(stash) : packname;
3110             packlen = strlen(packname);
3111         }
3112         else {
3113             /* the method name is qualified */
3114             packname = name;
3115             packlen = sep - name;
3116         }
3117
3118         /* we're relying on gv_fetchmethod not autovivifying the stash */
3119         if (gv_stashpvn(packname, packlen, FALSE)) {
3120             Perl_croak(aTHX_
3121                        "Can't locate object method \"%s\" via package \"%.*s\"",
3122                        leaf, (int)packlen, packname);
3123         }
3124         else {
3125             Perl_croak(aTHX_
3126                        "Can't locate object method \"%s\" via package \"%.*s\""
3127                        " (perhaps you forgot to load \"%.*s\"?)",
3128                        leaf, (int)packlen, packname, (int)packlen, packname);
3129         }
3130     }
3131     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3132 }
3133
3134 #ifdef USE_5005THREADS
3135 static void
3136 unset_cvowner(pTHX_ void *cvarg)
3137 {
3138     register CV* cv = (CV *) cvarg;
3139
3140     DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3141                            thr, cv, SvPEEK((SV*)cv))));
3142     MUTEX_LOCK(CvMUTEXP(cv));
3143     DEBUG_S(if (CvDEPTH(cv) != 0)
3144                 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3145                              CvDEPTH(cv)));
3146     assert(thr == CvOWNER(cv));
3147     CvOWNER(cv) = 0;
3148     MUTEX_UNLOCK(CvMUTEXP(cv));
3149     SvREFCNT_dec(cv);
3150 }
3151 #endif /* USE_5005THREADS */