pp_hot.c

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