pp_hot.c

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