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