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 bool is_gv = isGV_with_GP(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 && !is_gv && 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 (!is_gv) {
 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( isGV_with_GP(right) && 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 ( gv && 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                 SV** topelem = relem;
1065
1066                 hash = MUTABLE_HV(sv);
1067                 magic = SvMAGICAL(hash) != 0;
1068                 hv_clear(hash);
1069                 firsthashrelem = relem;
1070
1071                 while (relem < lastrelem) {     /* gobble up all the rest */
1072                     HE *didstore;
1073                     sv = *relem ? *relem : &PL_sv_no;
1074                     relem++;
1075                     tmpstr = newSV(0);
1076                     if (*relem)
1077                         sv_setsv(tmpstr,*relem);        /* value */
1078                     relem++;
1079                     if (gimme != G_VOID) {
1080                         if (hv_exists_ent(hash, sv, 0))
1081                             /* key overwrites an existing entry */
1082                             duplicates += 2;
1083                         else
1084                         if (gimme == G_ARRAY) {
1085                             /* copy element back: possibly to an earlier
1086                              * stack location if we encountered dups earlier */
1087                             *topelem++ = sv;
1088                             *topelem++ = tmpstr;
1089                         }
1090                     }
1091                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1092                     if (magic) {
1093                         if (SvSMAGICAL(tmpstr))
1094                             mg_set(tmpstr);
1095                         if (!didstore)
1096                             sv_2mortal(tmpstr);
1097                     }
1098                     TAINT_NOT;
1099                 }
1100                 if (relem == lastrelem) {
1101                     do_oddball(hash, relem, firstrelem);
1102                     relem++;
1103                 }
1104             }
1105             break;
1106         default:
1107             if (SvIMMORTAL(sv)) {
1108                 if (relem <= lastrelem)
1109                     relem++;
1110                 break;
1111             }
1112             if (relem <= lastrelem) {
1113                 sv_setsv(sv, *relem);
1114                 *(relem++) = sv;
1115             }
1116             else
1117                 sv_setsv(sv, &PL_sv_undef);
1118             SvSETMAGIC(sv);
1119             break;
1120         }
1121     }
1122     if (PL_delaymagic & ~DM_DELAY) {
1123         if (PL_delaymagic & DM_UID) {
1124 #ifdef HAS_SETRESUID
1125             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1126                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1127                             (Uid_t)-1);
1128 #else
1129 #  ifdef HAS_SETREUID
1130             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1131                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1132 #  else
1133 #    ifdef HAS_SETRUID
1134             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1135                 (void)setruid(PL_uid);
1136                 PL_delaymagic &= ~DM_RUID;
1137             }
1138 #    endif /* HAS_SETRUID */
1139 #    ifdef HAS_SETEUID
1140             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1141                 (void)seteuid(PL_euid);
1142                 PL_delaymagic &= ~DM_EUID;
1143             }
1144 #    endif /* HAS_SETEUID */
1145             if (PL_delaymagic & DM_UID) {
1146                 if (PL_uid != PL_euid)
1147                     DIE(aTHX_ "No setreuid available");
1148                 (void)PerlProc_setuid(PL_uid);
1149             }
1150 #  endif /* HAS_SETREUID */
1151 #endif /* HAS_SETRESUID */
1152             PL_uid = PerlProc_getuid();
1153             PL_euid = PerlProc_geteuid();
1154         }
1155         if (PL_delaymagic & DM_GID) {
1156 #ifdef HAS_SETRESGID
1157             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1158                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1159                             (Gid_t)-1);
1160 #else
1161 #  ifdef HAS_SETREGID
1162             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1163                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1164 #  else
1165 #    ifdef HAS_SETRGID
1166             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1167                 (void)setrgid(PL_gid);
1168                 PL_delaymagic &= ~DM_RGID;
1169             }
1170 #    endif /* HAS_SETRGID */
1171 #    ifdef HAS_SETEGID
1172             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1173                 (void)setegid(PL_egid);
1174                 PL_delaymagic &= ~DM_EGID;
1175             }
1176 #    endif /* HAS_SETEGID */
1177             if (PL_delaymagic & DM_GID) {
1178                 if (PL_gid != PL_egid)
1179                     DIE(aTHX_ "No setregid available");
1180                 (void)PerlProc_setgid(PL_gid);
1181             }
1182 #  endif /* HAS_SETREGID */
1183 #endif /* HAS_SETRESGID */
1184             PL_gid = PerlProc_getgid();
1185             PL_egid = PerlProc_getegid();
1186         }
1187         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1188     }
1189     PL_delaymagic = 0;
1190
1191     if (gimme == G_VOID)
1192         SP = firstrelem - 1;
1193     else if (gimme == G_SCALAR) {
1194         dTARGET;
1195         SP = firstrelem;
1196         SETi(lastrelem - firstrelem + 1 - duplicates);
1197     }
1198     else {
1199         if (ary)
1200             SP = lastrelem;
1201         else if (hash) {
1202             if (duplicates) {
1203                 /* at this point we have removed the duplicate key/value
1204                  * pairs from the stack, but the remaining values may be
1205                  * wrong; i.e. with (a 1 a 2 b 3) on the stack we've removed
1206                  * the (a 2), but the stack now probably contains
1207                  * (a <freed> b 3), because { hv_save(a,1); hv_save(a,2) }
1208                  * obliterates the earlier key. So refresh all values. */
1209                 lastrelem -= duplicates;
1210                 relem = firsthashrelem;
1211                 while (relem < lastrelem) {
1212                     HE *he;
1213                     sv = *relem++;
1214                     he = hv_fetch_ent(hash, sv, 0, 0);
1215                     *relem++ = (he ? HeVAL(he) : &PL_sv_undef);
1216                 }
1217             }
1218             SP = lastrelem;
1219         }
1220         else
1221             SP = firstrelem + (lastlelem - firstlelem);
1222         lelem = firstlelem + (relem - firstrelem);
1223         while (relem <= SP)
1224             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1225     }
1226
1227     RETURN;
1228 }
1229
1230 PP(pp_qr)
1231 {
1232     dVAR; dSP;
1233     register PMOP * const pm = cPMOP;
1234     REGEXP * rx = PM_GETRE(pm);
1235     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1236     SV * const rv = sv_newmortal();
1237
1238     SvUPGRADE(rv, SVt_IV);
1239     /* For a subroutine describing itself as "This is a hacky workaround" I'm
1240        loathe to use it here, but it seems to be the right fix. Or close.
1241        The key part appears to be that it's essential for pp_qr to return a new
1242        object (SV), which implies that there needs to be an effective way to
1243        generate a new SV from the existing SV that is pre-compiled in the
1244        optree.  */
1245     SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
1246     SvROK_on(rv);
1247
1248     if (pkg) {
1249         HV *const stash = gv_stashsv(pkg, GV_ADD);
1250         SvREFCNT_dec(pkg);
1251         (void)sv_bless(rv, stash);
1252     }
1253
1254     if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1255         SvTAINTED_on(rv);
1256     XPUSHs(rv);
1257     RETURN;
1258 }
1259
1260 PP(pp_match)
1261 {
1262     dVAR; dSP; dTARG;
1263     register PMOP *pm = cPMOP;
1264     PMOP *dynpm = pm;
1265     register const char *t;
1266     register const char *s;
1267     const char *strend;
1268     I32 global;
1269     U8 r_flags = REXEC_CHECKED;
1270     const char *truebase;                       /* Start of string  */
1271     register REGEXP *rx = PM_GETRE(pm);
1272     bool rxtainted;
1273     const I32 gimme = GIMME;
1274     STRLEN len;
1275     I32 minmatch = 0;
1276     const I32 oldsave = PL_savestack_ix;
1277     I32 update_minmatch = 1;
1278     I32 had_zerolen = 0;
1279     U32 gpos = 0;
1280
1281     if (PL_op->op_flags & OPf_STACKED)
1282         TARG = POPs;
1283     else if (PL_op->op_private & OPpTARGET_MY)
1284         GETTARGET;
1285     else {
1286         TARG = DEFSV;
1287         EXTEND(SP,1);
1288     }
1289
1290     PUTBACK;                            /* EVAL blocks need stack_sp. */
1291     /* Skip get-magic if this is a qr// clone, because regcomp has
1292        already done it. */
1293     s = ((struct regexp *)SvANY(rx))->mother_re
1294          ? SvPV_nomg_const(TARG, len)
1295          : SvPV_const(TARG, len);
1296     if (!s)
1297         DIE(aTHX_ "panic: pp_match");
1298     strend = s + len;
1299     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1300                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1301     TAINT_NOT;
1302
1303     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1304
1305     /* PMdf_USED is set after a ?? matches once */
1306     if (
1307 #ifdef USE_ITHREADS
1308         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1309 #else
1310         pm->op_pmflags & PMf_USED
1311 #endif
1312     ) {
1313       failure:
1314         if (gimme == G_ARRAY)
1315             RETURN;
1316         RETPUSHNO;
1317     }
1318
1319
1320
1321     /* empty pattern special-cased to use last successful pattern if possible */
1322     if (!RX_PRELEN(rx) && PL_curpm) {
1323         pm = PL_curpm;
1324         rx = PM_GETRE(pm);
1325     }
1326
1327     if (RX_MINLEN(rx) > (I32)len)
1328         goto failure;
1329
1330     truebase = t = s;
1331
1332     /* XXXX What part of this is needed with true \G-support? */
1333     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1334         RX_OFFS(rx)[0].start = -1;
1335         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1336             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1337             if (mg && mg->mg_len >= 0) {
1338                 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1339                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1340                 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1341                     r_flags |= REXEC_IGNOREPOS;
1342                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1343                 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1344                     gpos = mg->mg_len;
1345                 else
1346                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1347                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1348                 update_minmatch = 0;
1349             }
1350         }
1351     }
1352     /* XXX: comment out !global get safe $1 vars after a
1353        match, BUT be aware that this leads to dramatic slowdowns on
1354        /g matches against large strings.  So far a solution to this problem
1355        appears to be quite tricky.
1356        Test for the unsafe vars are TODO for now. */
1357     if (       (!global && RX_NPARENS(rx))
1358             || SvTEMP(TARG) || SvAMAGIC(TARG) || PL_sawampersand
1359             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1360         r_flags |= REXEC_COPY_STR;
1361     if (SvSCREAM(TARG))
1362         r_flags |= REXEC_SCREAM;
1363
1364 play_it_again:
1365     if (global && RX_OFFS(rx)[0].start != -1) {
1366         t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1367         if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1368             goto nope;
1369         if (update_minmatch++)
1370             minmatch = had_zerolen;
1371     }
1372     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1373         DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1374         /* FIXME - can PL_bostr be made const char *?  */
1375         PL_bostr = (char *)truebase;
1376         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1377
1378         if (!s)
1379             goto nope;
1380         if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1381              && !PL_sawampersand
1382              && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1383              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1384                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1385                       && (r_flags & REXEC_SCREAM)))
1386              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1387             goto yup;
1388     }
1389     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1390                     minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1391     {
1392         PL_curpm = pm;
1393         if (dynpm->op_pmflags & PMf_ONCE) {
1394 #ifdef USE_ITHREADS
1395             SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1396 #else
1397             dynpm->op_pmflags |= PMf_USED;
1398 #endif
1399         }
1400         goto gotcha;
1401     }
1402     else
1403         goto ret_no;
1404     /*NOTREACHED*/
1405
1406   gotcha:
1407     if (rxtainted)
1408         RX_MATCH_TAINTED_on(rx);
1409     TAINT_IF(RX_MATCH_TAINTED(rx));
1410     if (gimme == G_ARRAY) {
1411         const I32 nparens = RX_NPARENS(rx);
1412         I32 i = (global && !nparens) ? 1 : 0;
1413
1414         SPAGAIN;                        /* EVAL blocks could move the stack. */
1415         EXTEND(SP, nparens + i);
1416         EXTEND_MORTAL(nparens + i);
1417         for (i = !i; i <= nparens; i++) {
1418             PUSHs(sv_newmortal());
1419             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1420                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1421                 s = RX_OFFS(rx)[i].start + truebase;
1422                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1423                     len < 0 || len > strend - s)
1424                     DIE(aTHX_ "panic: pp_match start/end pointers");
1425                 sv_setpvn(*SP, s, len);
1426                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1427                     SvUTF8_on(*SP);
1428             }
1429         }
1430         if (global) {
1431             if (dynpm->op_pmflags & PMf_CONTINUE) {
1432                 MAGIC* mg = NULL;
1433                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1434                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1435                 if (!mg) {
1436 #ifdef PERL_OLD_COPY_ON_WRITE
1437                     if (SvIsCOW(TARG))
1438                         sv_force_normal_flags(TARG, 0);
1439 #endif
1440                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1441                                      &PL_vtbl_mglob, NULL, 0);
1442                 }
1443                 if (RX_OFFS(rx)[0].start != -1) {
1444                     mg->mg_len = RX_OFFS(rx)[0].end;
1445                     if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1446                         mg->mg_flags |= MGf_MINMATCH;
1447                     else
1448                         mg->mg_flags &= ~MGf_MINMATCH;
1449                 }
1450             }
1451             had_zerolen = (RX_OFFS(rx)[0].start != -1
1452                            && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1453                                == (UV)RX_OFFS(rx)[0].end));
1454             PUTBACK;                    /* EVAL blocks may use stack */
1455             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1456             goto play_it_again;
1457         }
1458         else if (!nparens)
1459             XPUSHs(&PL_sv_yes);
1460         LEAVE_SCOPE(oldsave);
1461         RETURN;
1462     }
1463     else {
1464         if (global) {
1465             MAGIC* mg;
1466             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1467                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1468             else
1469                 mg = NULL;
1470             if (!mg) {
1471 #ifdef PERL_OLD_COPY_ON_WRITE
1472                 if (SvIsCOW(TARG))
1473                     sv_force_normal_flags(TARG, 0);
1474 #endif
1475                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1476                                  &PL_vtbl_mglob, NULL, 0);
1477             }
1478             if (RX_OFFS(rx)[0].start != -1) {
1479                 mg->mg_len = RX_OFFS(rx)[0].end;
1480                 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1481                     mg->mg_flags |= MGf_MINMATCH;
1482                 else
1483                     mg->mg_flags &= ~MGf_MINMATCH;
1484             }
1485         }
1486         LEAVE_SCOPE(oldsave);
1487         RETPUSHYES;
1488     }
1489
1490 yup:                                    /* Confirmed by INTUIT */
1491     if (rxtainted)
1492         RX_MATCH_TAINTED_on(rx);
1493     TAINT_IF(RX_MATCH_TAINTED(rx));
1494     PL_curpm = pm;
1495     if (dynpm->op_pmflags & PMf_ONCE) {
1496 #ifdef USE_ITHREADS
1497         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1498 #else
1499         dynpm->op_pmflags |= PMf_USED;
1500 #endif
1501     }
1502     if (RX_MATCH_COPIED(rx))
1503         Safefree(RX_SUBBEG(rx));
1504     RX_MATCH_COPIED_off(rx);
1505     RX_SUBBEG(rx) = NULL;
1506     if (global) {
1507         /* FIXME - should rx->subbeg be const char *?  */
1508         RX_SUBBEG(rx) = (char *) truebase;
1509         RX_OFFS(rx)[0].start = s - truebase;
1510         if (RX_MATCH_UTF8(rx)) {
1511             char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1512             RX_OFFS(rx)[0].end = t - truebase;
1513         }
1514         else {
1515             RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1516         }
1517         RX_SUBLEN(rx) = strend - truebase;
1518         goto gotcha;
1519     }
1520     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1521         I32 off;
1522 #ifdef PERL_OLD_COPY_ON_WRITE
1523         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1524             if (DEBUG_C_TEST) {
1525                 PerlIO_printf(Perl_debug_log,
1526                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1527                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1528                               (int)(t-truebase));
1529             }
1530             RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1531             RX_SUBBEG(rx)
1532                 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1533             assert (SvPOKp(RX_SAVED_COPY(rx)));
1534         } else
1535 #endif
1536         {
1537
1538             RX_SUBBEG(rx) = savepvn(t, strend - t);
1539 #ifdef PERL_OLD_COPY_ON_WRITE
1540             RX_SAVED_COPY(rx) = NULL;
1541 #endif
1542         }
1543         RX_SUBLEN(rx) = strend - t;
1544         RX_MATCH_COPIED_on(rx);
1545         off = RX_OFFS(rx)[0].start = s - t;
1546         RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1547     }
1548     else {                      /* startp/endp are used by @- @+. */
1549         RX_OFFS(rx)[0].start = s - truebase;
1550         RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1551     }
1552     /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1553        -dmq */
1554     RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;      /* used by @-, @+, and $^N */
1555     LEAVE_SCOPE(oldsave);
1556     RETPUSHYES;
1557
1558 nope:
1559 ret_no:
1560     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1561         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1562             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1563             if (mg)
1564                 mg->mg_len = -1;
1565         }
1566     }
1567     LEAVE_SCOPE(oldsave);
1568     if (gimme == G_ARRAY)
1569         RETURN;
1570     RETPUSHNO;
1571 }
1572
1573 OP *
1574 Perl_do_readline(pTHX)
1575 {
1576     dVAR; dSP; dTARGETSTACKED;
1577     register SV *sv;
1578     STRLEN tmplen = 0;
1579     STRLEN offset;
1580     PerlIO *fp;
1581     register IO * const io = GvIO(PL_last_in_gv);
1582     register const I32 type = PL_op->op_type;
1583     const I32 gimme = GIMME_V;
1584
1585     if (io) {
1586         MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1587         if (mg) {
1588             PUSHMARK(SP);
1589             XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1590             PUTBACK;
1591             ENTER_with_name("call_READLINE");
1592             call_method("READLINE", gimme);
1593             LEAVE_with_name("call_READLINE");
1594             SPAGAIN;
1595             if (gimme == G_SCALAR) {
1596                 SV* const result = POPs;
1597                 SvSetSV_nosteal(TARG, result);
1598                 PUSHTARG;
1599             }
1600             RETURN;
1601         }
1602     }
1603     fp = NULL;
1604     if (io) {
1605         fp = IoIFP(io);
1606         if (!fp) {
1607             if (IoFLAGS(io) & IOf_ARGV) {
1608                 if (IoFLAGS(io) & IOf_START) {
1609                     IoLINES(io) = 0;
1610                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1611                         IoFLAGS(io) &= ~IOf_START;
1612                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1613                         sv_setpvs(GvSVn(PL_last_in_gv), "-");
1614                         SvSETMAGIC(GvSV(PL_last_in_gv));
1615                         fp = IoIFP(io);
1616                         goto have_fp;
1617                     }
1618                 }
1619                 fp = nextargv(PL_last_in_gv);
1620                 if (!fp) { /* Note: fp != IoIFP(io) */
1621                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1622                 }
1623             }
1624             else if (type == OP_GLOB)
1625                 fp = Perl_start_glob(aTHX_ POPs, io);
1626         }
1627         else if (type == OP_GLOB)
1628             SP--;
1629         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1630             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1631         }
1632     }
1633     if (!fp) {
1634         if ((!io || !(IoFLAGS(io) & IOf_START))
1635             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1636         {
1637             if (type == OP_GLOB)
1638                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1639                             "glob failed (can't start child: %s)",
1640                             Strerror(errno));
1641             else
1642                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1643         }
1644         if (gimme == G_SCALAR) {
1645             /* undef TARG, and push that undefined value */
1646             if (type != OP_RCATLINE) {
1647                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1648                 SvOK_off(TARG);
1649             }
1650             PUSHTARG;
1651         }
1652         RETURN;
1653     }
1654   have_fp:
1655     if (gimme == G_SCALAR) {
1656         sv = TARG;
1657         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1658             mg_get(sv);
1659         if (SvROK(sv)) {
1660             if (type == OP_RCATLINE)
1661                 SvPV_force_nolen(sv);
1662             else
1663                 sv_unref(sv);
1664         }
1665         else if (isGV_with_GP(sv)) {
1666             SvPV_force_nolen(sv);
1667         }
1668         SvUPGRADE(sv, SVt_PV);
1669         tmplen = SvLEN(sv);     /* remember if already alloced */
1670         if (!tmplen && !SvREADONLY(sv)) {
1671             /* try short-buffering it. Please update t/op/readline.t
1672              * if you change the growth length.
1673              */
1674             Sv_Grow(sv, 80);
1675         }
1676         offset = 0;
1677         if (type == OP_RCATLINE && SvOK(sv)) {
1678             if (!SvPOK(sv)) {
1679                 SvPV_force_nolen(sv);
1680             }
1681             offset = SvCUR(sv);
1682         }
1683     }
1684     else {
1685         sv = sv_2mortal(newSV(80));
1686         offset = 0;
1687     }
1688
1689     /* This should not be marked tainted if the fp is marked clean */
1690 #define MAYBE_TAINT_LINE(io, sv) \
1691     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1692         TAINT;                          \
1693         SvTAINTED_on(sv);               \
1694     }
1695
1696 /* delay EOF state for a snarfed empty file */
1697 #define SNARF_EOF(gimme,rs,io,sv) \
1698     (gimme != G_SCALAR || SvCUR(sv)                                     \
1699      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1700
1701     for (;;) {
1702         PUTBACK;
1703         if (!sv_gets(sv, fp, offset)
1704             && (type == OP_GLOB
1705                 || SNARF_EOF(gimme, PL_rs, io, sv)
1706                 || PerlIO_error(fp)))
1707         {
1708             PerlIO_clearerr(fp);
1709             if (IoFLAGS(io) & IOf_ARGV) {
1710                 fp = nextargv(PL_last_in_gv);
1711                 if (fp)
1712                     continue;
1713                 (void)do_close(PL_last_in_gv, FALSE);
1714             }
1715             else if (type == OP_GLOB) {
1716                 if (!do_close(PL_last_in_gv, FALSE)) {
1717                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1718                                    "glob failed (child exited with status %d%s)",
1719                                    (int)(STATUS_CURRENT >> 8),
1720                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1721                 }
1722             }
1723             if (gimme == G_SCALAR) {
1724                 if (type != OP_RCATLINE) {
1725                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1726                     SvOK_off(TARG);
1727                 }
1728                 SPAGAIN;
1729                 PUSHTARG;
1730             }
1731             MAYBE_TAINT_LINE(io, sv);
1732             RETURN;
1733         }
1734         MAYBE_TAINT_LINE(io, sv);
1735         IoLINES(io)++;
1736         IoFLAGS(io) |= IOf_NOLINE;
1737         SvSETMAGIC(sv);
1738         SPAGAIN;
1739         XPUSHs(sv);
1740         if (type == OP_GLOB) {
1741             const char *t1;
1742
1743             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1744                 char * const tmps = SvEND(sv) - 1;
1745                 if (*tmps == *SvPVX_const(PL_rs)) {
1746                     *tmps = '\0';
1747                     SvCUR_set(sv, SvCUR(sv) - 1);
1748                 }
1749             }
1750             for (t1 = SvPVX_const(sv); *t1; t1++)
1751                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1752                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1753                         break;
1754             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1755                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1756                 continue;
1757             }
1758         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1759              if (ckWARN(WARN_UTF8)) {
1760                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1761                 const STRLEN len = SvCUR(sv) - offset;
1762                 const U8 *f;
1763
1764                 if (!is_utf8_string_loc(s, len, &f))
1765                     /* Emulate :encoding(utf8) warning in the same case. */
1766                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1767                                 "utf8 \"\\x%02X\" does not map to Unicode",
1768                                 f < (U8*)SvEND(sv) ? *f : 0);
1769              }
1770         }
1771         if (gimme == G_ARRAY) {
1772             if (SvLEN(sv) - SvCUR(sv) > 20) {
1773                 SvPV_shrink_to_cur(sv);
1774             }
1775             sv = sv_2mortal(newSV(80));
1776             continue;
1777         }
1778         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1779             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1780             const STRLEN new_len
1781                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1782             SvPV_renew(sv, new_len);
1783         }
1784         RETURN;
1785     }
1786 }
1787
1788 PP(pp_enter)
1789 {
1790     dVAR; dSP;
1791     register PERL_CONTEXT *cx;
1792     I32 gimme = OP_GIMME(PL_op, -1);
1793
1794     if (gimme == -1) {
1795         if (cxstack_ix >= 0) {
1796             /* If this flag is set, we're just inside a return, so we should
1797              * store the caller's context */
1798             gimme = (PL_op->op_flags & OPf_SPECIAL)
1799                 ? block_gimme()
1800                 : cxstack[cxstack_ix].blk_gimme;
1801         } else
1802             gimme = G_SCALAR;
1803     }
1804
1805     ENTER_with_name("block");
1806
1807     SAVETMPS;
1808     PUSHBLOCK(cx, CXt_BLOCK, SP);
1809
1810     RETURN;
1811 }
1812
1813 PP(pp_helem)
1814 {
1815     dVAR; dSP;
1816     HE* he;
1817     SV **svp;
1818     SV * const keysv = POPs;
1819     HV * const hv = MUTABLE_HV(POPs);
1820     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1821     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1822     SV *sv;
1823     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1824     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1825     bool preeminent = TRUE;
1826
1827     if (SvTYPE(hv) != SVt_PVHV)
1828         RETPUSHUNDEF;
1829
1830     if (localizing) {
1831         MAGIC *mg;
1832         HV *stash;
1833
1834         /* If we can determine whether the element exist,
1835          * Try to preserve the existenceness of a tied hash
1836          * element by using EXISTS and DELETE if possible.
1837          * Fallback to FETCH and STORE otherwise. */
1838         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1839             preeminent = hv_exists_ent(hv, keysv, 0);
1840     }
1841
1842     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1843     svp = he ? &HeVAL(he) : NULL;
1844     if (lval) {
1845         if (!svp || *svp == &PL_sv_undef) {
1846             SV* lv;
1847             SV* key2;
1848             if (!defer) {
1849                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1850             }
1851             lv = sv_newmortal();
1852             sv_upgrade(lv, SVt_PVLV);
1853             LvTYPE(lv) = 'y';
1854             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1855             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1856             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1857             LvTARGLEN(lv) = 1;
1858             PUSHs(lv);
1859             RETURN;
1860         }
1861         if (localizing) {
1862             if (HvNAME_get(hv) && isGV(*svp))
1863                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1864             else if (preeminent)
1865                 save_helem_flags(hv, keysv, svp,
1866                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1867             else
1868                 SAVEHDELETE(hv, keysv);
1869         }
1870         else if (PL_op->op_private & OPpDEREF)
1871             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1872     }
1873     sv = (svp ? *svp : &PL_sv_undef);
1874     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1875      * was to make C<local $tied{foo} = $tied{foo}> possible.
1876      * However, it seems no longer to be needed for that purpose, and
1877      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1878      * would loop endlessly since the pos magic is getting set on the
1879      * mortal copy and lost. However, the copy has the effect of
1880      * triggering the get magic, and losing it altogether made things like
1881      * c<$tied{foo};> in void context no longer do get magic, which some
1882      * code relied on. Also, delayed triggering of magic on @+ and friends
1883      * meant the original regex may be out of scope by now. So as a
1884      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1885      * being called too many times). */
1886     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1887         mg_get(sv);
1888     PUSHs(sv);
1889     RETURN;
1890 }
1891
1892 PP(pp_leave)
1893 {
1894     dVAR; dSP;
1895     register PERL_CONTEXT *cx;
1896     SV **newsp;
1897     PMOP *newpm;
1898     I32 gimme;
1899
1900     if (PL_op->op_flags & OPf_SPECIAL) {
1901         cx = &cxstack[cxstack_ix];
1902         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1903     }
1904
1905     POPBLOCK(cx,newpm);
1906
1907     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1908
1909     TAINT_NOT;
1910     if (gimme == G_VOID)
1911         SP = newsp;
1912     else if (gimme == G_SCALAR) {
1913         register SV **mark;
1914         MARK = newsp + 1;
1915         if (MARK <= SP) {
1916             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1917                 *MARK = TOPs;
1918             else
1919                 *MARK = sv_mortalcopy(TOPs);
1920         } else {
1921             MEXTEND(mark,0);
1922             *MARK = &PL_sv_undef;
1923         }
1924         SP = MARK;
1925     }
1926     else if (gimme == G_ARRAY) {
1927         /* in case LEAVE wipes old return values */
1928         register SV **mark;
1929         for (mark = newsp + 1; mark <= SP; mark++) {
1930             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1931                 *mark = sv_mortalcopy(*mark);
1932                 TAINT_NOT;      /* Each item is independent */
1933             }
1934         }
1935     }
1936     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1937
1938     LEAVE_with_name("block");
1939
1940     RETURN;
1941 }
1942
1943 PP(pp_iter)
1944 {
1945     dVAR; dSP;
1946     register PERL_CONTEXT *cx;
1947     SV *sv, *oldsv;
1948     SV **itersvp;
1949     AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1950     bool av_is_stack = FALSE;
1951
1952     EXTEND(SP, 1);
1953     cx = &cxstack[cxstack_ix];
1954     if (!CxTYPE_is_LOOP(cx))
1955         DIE(aTHX_ "panic: pp_iter");
1956
1957     itersvp = CxITERVAR(cx);
1958     if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1959             /* string increment */
1960             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1961             SV *end = cx->blk_loop.state_u.lazysv.end;
1962             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1963                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1964             STRLEN maxlen = 0;
1965             const char *max = SvPV_const(end, maxlen);
1966             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1967                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1968                     /* safe to reuse old SV */
1969                     sv_setsv(*itersvp, cur);
1970                 }
1971                 else
1972                 {
1973                     /* we need a fresh SV every time so that loop body sees a
1974                      * completely new SV for closures/references to work as
1975                      * they used to */
1976                     oldsv = *itersvp;
1977                     *itersvp = newSVsv(cur);
1978                     SvREFCNT_dec(oldsv);
1979                 }
1980                 if (strEQ(SvPVX_const(cur), max))
1981                     sv_setiv(cur, 0); /* terminate next time */
1982                 else
1983                     sv_inc(cur);
1984                 RETPUSHYES;
1985             }
1986             RETPUSHNO;
1987     }
1988     else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1989         /* integer increment */
1990         if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1991             RETPUSHNO;
1992
1993         /* don't risk potential race */
1994         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1995             /* safe to reuse old SV */
1996             sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1997         }
1998         else
1999         {
2000             /* we need a fresh SV every time so that loop body sees a
2001              * completely new SV for closures/references to work as they
2002              * used to */
2003             oldsv = *itersvp;
2004             *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
2005             SvREFCNT_dec(oldsv);
2006         }
2007
2008         /* Handle end of range at IV_MAX */
2009         if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
2010             (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
2011         {
2012             cx->blk_loop.state_u.lazyiv.cur++;
2013             cx->blk_loop.state_u.lazyiv.end++;
2014         }
2015
2016         RETPUSHYES;
2017     }
2018
2019     /* iterate array */
2020     assert(CxTYPE(cx) == CXt_LOOP_FOR);
2021     av = cx->blk_loop.state_u.ary.ary;
2022     if (!av) {
2023         av_is_stack = TRUE;
2024         av = PL_curstack;
2025     }
2026     if (PL_op->op_private & OPpITER_REVERSED) {
2027         if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2028                                     ? cx->blk_loop.resetsp + 1 : 0))
2029             RETPUSHNO;
2030
2031         if (SvMAGICAL(av) || AvREIFY(av)) {
2032             SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2033             sv = svp ? *svp : NULL;
2034         }
2035         else {
2036             sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2037         }
2038     }
2039     else {
2040         if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2041                                     AvFILL(av)))
2042             RETPUSHNO;
2043
2044         if (SvMAGICAL(av) || AvREIFY(av)) {
2045             SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2046             sv = svp ? *svp : NULL;
2047         }
2048         else {
2049             sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2050         }
2051     }
2052
2053     if (sv && SvIS_FREED(sv)) {
2054         *itersvp = NULL;
2055         Perl_croak(aTHX_ "Use of freed value in iteration");
2056     }
2057
2058     if (sv) {
2059         SvTEMP_off(sv);
2060         SvREFCNT_inc_simple_void_NN(sv);
2061     }
2062     else
2063         sv = &PL_sv_undef;
2064     if (!av_is_stack && sv == &PL_sv_undef) {
2065         SV *lv = newSV_type(SVt_PVLV);
2066         LvTYPE(lv) = 'y';
2067         sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2068         LvTARG(lv) = SvREFCNT_inc_simple(av);
2069         LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2070         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2071         sv = lv;
2072     }
2073
2074     oldsv = *itersvp;
2075     *itersvp = sv;
2076     SvREFCNT_dec(oldsv);
2077
2078     RETPUSHYES;
2079 }
2080
2081 PP(pp_subst)
2082 {
2083     dVAR; dSP; dTARG;
2084     register PMOP *pm = cPMOP;
2085     PMOP *rpm = pm;
2086     register char *s;
2087     char *strend;
2088     register char *m;
2089     const char *c;
2090     register char *d;
2091     STRLEN clen;
2092     I32 iters = 0;
2093     I32 maxiters;
2094     register I32 i;
2095     bool once;
2096     U8 rxtainted;
2097     char *orig;
2098     U8 r_flags;
2099     register REGEXP *rx = PM_GETRE(pm);
2100     STRLEN len;
2101     int force_on_match = 0;
2102     const I32 oldsave = PL_savestack_ix;
2103     STRLEN slen;
2104     bool doutf8 = FALSE;
2105     I32 matched;
2106 #ifdef PERL_OLD_COPY_ON_WRITE
2107     bool is_cow;
2108 #endif
2109     SV *nsv = NULL;
2110     /* known replacement string? */
2111     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2112
2113     PERL_ASYNC_CHECK();
2114
2115     if (PL_op->op_flags & OPf_STACKED)
2116         TARG = POPs;
2117     else if (PL_op->op_private & OPpTARGET_MY)
2118         GETTARGET;
2119     else {
2120         TARG = DEFSV;
2121         EXTEND(SP,1);
2122     }
2123
2124     /* In non-destructive replacement mode, duplicate target scalar so it
2125      * remains unchanged. */
2126     if (rpm->op_pmflags & PMf_NONDESTRUCT)
2127         TARG = newSVsv(TARG);
2128
2129 #ifdef PERL_OLD_COPY_ON_WRITE
2130     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2131        because they make integers such as 256 "false".  */
2132     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2133 #else
2134     if (SvIsCOW(TARG))
2135         sv_force_normal_flags(TARG,0);
2136 #endif
2137     if (
2138 #ifdef PERL_OLD_COPY_ON_WRITE
2139         !is_cow &&
2140 #endif
2141         (SvREADONLY(TARG)
2142          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2143                || SvTYPE(TARG) > SVt_PVLV)
2144              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2145         Perl_croak_no_modify(aTHX);
2146     PUTBACK;
2147
2148   setup_match:
2149     s = SvPV_mutable(TARG, len);
2150     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2151         force_on_match = 1;
2152     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2153                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2154     if (PL_tainted)
2155         rxtainted |= 2;
2156     TAINT_NOT;
2157
2158     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2159
2160   force_it:
2161     if (!pm || !s)
2162         DIE(aTHX_ "panic: pp_subst");
2163
2164     strend = s + len;
2165     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2166     maxiters = 2 * slen + 10;   /* We can match twice at each
2167                                    position, once with zero-length,
2168                                    second time with non-zero. */
2169
2170     if (!RX_PRELEN(rx) && PL_curpm) {
2171         pm = PL_curpm;
2172         rx = PM_GETRE(pm);
2173     }
2174     r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2175             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2176                ? REXEC_COPY_STR : 0;
2177     if (SvSCREAM(TARG))
2178         r_flags |= REXEC_SCREAM;
2179
2180     orig = m = s;
2181     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2182         PL_bostr = orig;
2183         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2184
2185         if (!s)
2186             goto nope;
2187         /* How to do it in subst? */
2188 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2189              && !PL_sawampersand
2190              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2191              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2192                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2193                       && (r_flags & REXEC_SCREAM))))
2194             goto yup;
2195 */
2196     }
2197
2198     /* only replace once? */
2199     once = !(rpm->op_pmflags & PMf_GLOBAL);
2200     matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2201                          r_flags | REXEC_CHECKED);
2202     /* known replacement string? */
2203     if (dstr) {
2204
2205         /* Upgrade the source if the replacement is utf8 but the source is not,
2206          * but only if it matched; see
2207          * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2208          */
2209         if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2210             const STRLEN new_len = sv_utf8_upgrade(TARG);
2211
2212             /* If the lengths are the same, the pattern contains only
2213              * invariants, can keep going; otherwise, various internal markers
2214              * could be off, so redo */
2215             if (new_len != len) {
2216                 goto setup_match;
2217             }
2218         }
2219
2220         /* replacement needing upgrading? */
2221         if (DO_UTF8(TARG) && !doutf8) {
2222              nsv = sv_newmortal();
2223              SvSetSV(nsv, dstr);
2224              if (PL_encoding)
2225                   sv_recode_to_utf8(nsv, PL_encoding);
2226              else
2227                   sv_utf8_upgrade(nsv);
2228              c = SvPV_const(nsv, clen);
2229              doutf8 = TRUE;
2230         }
2231         else {
2232             c = SvPV_const(dstr, clen);
2233             doutf8 = DO_UTF8(dstr);
2234         }
2235     }
2236     else {
2237         c = NULL;
2238         doutf8 = FALSE;
2239     }
2240
2241     /* can do inplace substitution? */
2242     if (c
2243 #ifdef PERL_OLD_COPY_ON_WRITE
2244         && !is_cow
2245 #endif
2246         && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2247         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2248         && (!doutf8 || SvUTF8(TARG))) {
2249         if (!matched)
2250         {
2251             SPAGAIN;
2252             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2253                 PUSHs(TARG);
2254             else
2255                 PUSHs(&PL_sv_no);
2256             LEAVE_SCOPE(oldsave);
2257             RETURN;
2258         }
2259 #ifdef PERL_OLD_COPY_ON_WRITE
2260         if (SvIsCOW(TARG)) {
2261             assert (!force_on_match);
2262             goto have_a_cow;
2263         }
2264 #endif
2265         if (force_on_match) {
2266             force_on_match = 0;
2267             s = SvPV_force(TARG, len);
2268             goto force_it;
2269         }
2270         d = s;
2271         PL_curpm = pm;
2272         SvSCREAM_off(TARG);     /* disable possible screamer */
2273         if (once) {
2274             rxtainted |= RX_MATCH_TAINTED(rx);
2275             m = orig + RX_OFFS(rx)[0].start;
2276             d = orig + RX_OFFS(rx)[0].end;
2277             s = orig;
2278             if (m - s > strend - d) {  /* faster to shorten from end */
2279                 if (clen) {
2280                     Copy(c, m, clen, char);
2281                     m += clen;
2282                 }
2283                 i = strend - d;
2284                 if (i > 0) {
2285                     Move(d, m, i, char);
2286                     m += i;
2287                 }
2288                 *m = '\0';
2289                 SvCUR_set(TARG, m - s);
2290             }
2291             else if ((i = m - s)) {     /* faster from front */
2292                 d -= clen;
2293                 m = d;
2294                 Move(s, d - i, i, char);
2295                 sv_chop(TARG, d-i);
2296                 if (clen)
2297                     Copy(c, m, clen, char);
2298             }
2299             else if (clen) {
2300                 d -= clen;
2301                 sv_chop(TARG, d);
2302                 Copy(c, d, clen, char);
2303             }
2304             else {
2305                 sv_chop(TARG, d);
2306             }
2307             TAINT_IF(rxtainted & 1);
2308             SPAGAIN;
2309             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2310                 PUSHs(TARG);
2311             else
2312                 PUSHs(&PL_sv_yes);
2313         }
2314         else {
2315             do {
2316                 if (iters++ > maxiters)
2317                     DIE(aTHX_ "Substitution loop");
2318                 rxtainted |= RX_MATCH_TAINTED(rx);
2319                 m = RX_OFFS(rx)[0].start + orig;
2320                 if ((i = m - s)) {
2321                     if (s != d)
2322                         Move(s, d, i, char);
2323                     d += i;
2324                 }
2325                 if (clen) {
2326                     Copy(c, d, clen, char);
2327                     d += clen;
2328                 }
2329                 s = RX_OFFS(rx)[0].end + orig;
2330             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2331                                  TARG, NULL,
2332                                  /* don't match same null twice */
2333                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2334             if (s != d) {
2335                 i = strend - s;
2336                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2337                 Move(s, d, i+1, char);          /* include the NUL */
2338             }
2339             TAINT_IF(rxtainted & 1);
2340             SPAGAIN;
2341             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2342                 PUSHs(TARG);
2343             else
2344                 mPUSHi((I32)iters);
2345         }
2346         (void)SvPOK_only_UTF8(TARG);
2347         TAINT_IF(rxtainted);
2348         if (SvSMAGICAL(TARG)) {
2349             PUTBACK;
2350             mg_set(TARG);
2351             SPAGAIN;
2352         }
2353         SvTAINT(TARG);
2354         if (doutf8)
2355             SvUTF8_on(TARG);
2356         LEAVE_SCOPE(oldsave);
2357         RETURN;
2358     }
2359
2360     if (matched)
2361     {
2362         if (force_on_match) {
2363             force_on_match = 0;
2364             s = SvPV_force(TARG, len);
2365             goto force_it;
2366         }
2367 #ifdef PERL_OLD_COPY_ON_WRITE
2368       have_a_cow:
2369 #endif
2370         rxtainted |= RX_MATCH_TAINTED(rx);
2371         dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2372         SAVEFREESV(dstr);
2373         PL_curpm = pm;
2374         if (!c) {
2375             register PERL_CONTEXT *cx;
2376             SPAGAIN;
2377             PUSHSUBST(cx);
2378             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2379         }
2380         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2381         do {
2382             if (iters++ > maxiters)
2383                 DIE(aTHX_ "Substitution loop");
2384             rxtainted |= RX_MATCH_TAINTED(rx);
2385             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2386                 m = s;
2387                 s = orig;
2388                 orig = RX_SUBBEG(rx);
2389                 s = orig + (m - s);
2390                 strend = s + (strend - m);
2391             }
2392             m = RX_OFFS(rx)[0].start + orig;
2393             if (doutf8 && !SvUTF8(dstr))
2394                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2395             else
2396                 sv_catpvn(dstr, s, m-s);
2397             s = RX_OFFS(rx)[0].end + orig;
2398             if (clen)
2399                 sv_catpvn(dstr, c, clen);
2400             if (once)
2401                 break;
2402         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2403                              TARG, NULL, r_flags));
2404         if (doutf8 && !DO_UTF8(TARG))
2405             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2406         else
2407             sv_catpvn(dstr, s, strend - s);
2408
2409 #ifdef PERL_OLD_COPY_ON_WRITE
2410         /* The match may make the string COW. If so, brilliant, because that's
2411            just saved us one malloc, copy and free - the regexp has donated
2412            the old buffer, and we malloc an entirely new one, rather than the
2413            regexp malloc()ing a buffer and copying our original, only for
2414            us to throw it away here during the substitution.  */
2415         if (SvIsCOW(TARG)) {
2416             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2417         } else
2418 #endif
2419         {
2420             SvPV_free(TARG);
2421         }
2422         SvPV_set(TARG, SvPVX(dstr));
2423         SvCUR_set(TARG, SvCUR(dstr));
2424         SvLEN_set(TARG, SvLEN(dstr));
2425         doutf8 |= DO_UTF8(dstr);
2426         SvPV_set(dstr, NULL);
2427
2428         TAINT_IF(rxtainted & 1);
2429         SPAGAIN;
2430         if (rpm->op_pmflags & PMf_NONDESTRUCT)
2431             PUSHs(TARG);
2432         else
2433             mPUSHi((I32)iters);
2434
2435         (void)SvPOK_only(TARG);
2436         if (doutf8)
2437             SvUTF8_on(TARG);
2438         TAINT_IF(rxtainted);
2439         SvSETMAGIC(TARG);
2440         SvTAINT(TARG);
2441         LEAVE_SCOPE(oldsave);
2442         RETURN;
2443     }
2444     goto ret_no;
2445
2446 nope:
2447 ret_no:
2448     SPAGAIN;
2449     if (rpm->op_pmflags & PMf_NONDESTRUCT)
2450         PUSHs(TARG);
2451     else
2452         PUSHs(&PL_sv_no);
2453     LEAVE_SCOPE(oldsave);
2454     RETURN;
2455 }
2456
2457 PP(pp_grepwhile)
2458 {
2459     dVAR; dSP;
2460
2461     if (SvTRUEx(POPs))
2462         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2463     ++*PL_markstack_ptr;
2464     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2465
2466     /* All done yet? */
2467     if (PL_stack_base + *PL_markstack_ptr > SP) {
2468         I32 items;
2469         const I32 gimme = GIMME_V;
2470
2471         LEAVE_with_name("grep");                                        /* exit outer scope */
2472         (void)POPMARK;                          /* pop src */
2473         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2474         (void)POPMARK;                          /* pop dst */
2475         SP = PL_stack_base + POPMARK;           /* pop original mark */
2476         if (gimme == G_SCALAR) {
2477             if (PL_op->op_private & OPpGREP_LEX) {
2478                 SV* const sv = sv_newmortal();
2479                 sv_setiv(sv, items);
2480                 PUSHs(sv);
2481             }
2482             else {
2483                 dTARGET;
2484                 XPUSHi(items);
2485             }
2486         }
2487         else if (gimme == G_ARRAY)
2488             SP += items;
2489         RETURN;
2490     }
2491     else {
2492         SV *src;
2493
2494         ENTER_with_name("grep_item");                                   /* enter inner scope */
2495         SAVEVPTR(PL_curpm);
2496
2497         src = PL_stack_base[*PL_markstack_ptr];
2498         SvTEMP_off(src);
2499         if (PL_op->op_private & OPpGREP_LEX)
2500             PAD_SVl(PL_op->op_targ) = src;
2501         else
2502             DEFSV_set(src);
2503
2504         RETURNOP(cLOGOP->op_other);
2505     }
2506 }
2507
2508 PP(pp_leavesub)
2509 {
2510     dVAR; dSP;
2511     SV **mark;
2512     SV **newsp;
2513     PMOP *newpm;
2514     I32 gimme;
2515     register PERL_CONTEXT *cx;
2516     SV *sv;
2517
2518     if (CxMULTICALL(&cxstack[cxstack_ix]))
2519         return 0;
2520
2521     POPBLOCK(cx,newpm);
2522     cxstack_ix++; /* temporarily protect top context */
2523
2524     TAINT_NOT;
2525     if (gimme == G_SCALAR) {
2526         MARK = newsp + 1;
2527         if (MARK <= SP) {
2528             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2529                 if (SvTEMP(TOPs)) {
2530                     *MARK = SvREFCNT_inc(TOPs);
2531                     FREETMPS;
2532                     sv_2mortal(*MARK);
2533                 }
2534                 else {
2535                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2536                     FREETMPS;
2537                     *MARK = sv_mortalcopy(sv);
2538                     SvREFCNT_dec(sv);
2539                 }
2540             }
2541             else
2542                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2543         }
2544         else {
2545             MEXTEND(MARK, 0);
2546             *MARK = &PL_sv_undef;
2547         }
2548         SP = MARK;
2549     }
2550     else if (gimme == G_ARRAY) {
2551         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2552             if (!SvTEMP(*MARK)) {
2553                 *MARK = sv_mortalcopy(*MARK);
2554                 TAINT_NOT;      /* Each item is independent */
2555             }
2556         }
2557     }
2558     PUTBACK;
2559
2560     LEAVE;
2561     cxstack_ix--;
2562     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2563     PL_curpm = newpm;   /* ... and pop $1 et al */
2564
2565     LEAVESUB(sv);
2566     return cx->blk_sub.retop;
2567 }
2568
2569 /* This duplicates the above code because the above code must not
2570  * get any slower by more conditions */
2571 PP(pp_leavesublv)
2572 {
2573     dVAR; dSP;
2574     SV **mark;
2575     SV **newsp;
2576     PMOP *newpm;
2577     I32 gimme;
2578     register PERL_CONTEXT *cx;
2579     SV *sv;
2580
2581     if (CxMULTICALL(&cxstack[cxstack_ix]))
2582         return 0;
2583
2584     POPBLOCK(cx,newpm);
2585     cxstack_ix++; /* temporarily protect top context */
2586
2587     TAINT_NOT;
2588
2589     if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2590         /* We are an argument to a function or grep().
2591          * This kind of lvalueness was legal before lvalue
2592          * subroutines too, so be backward compatible:
2593          * cannot report errors.  */
2594
2595         /* Scalar context *is* possible, on the LHS of -> only,
2596          * as in f()->meth().  But this is not an lvalue. */
2597         if (gimme == G_SCALAR)
2598             goto temporise;
2599         if (gimme == G_ARRAY) {
2600             if (!CvLVALUE(cx->blk_sub.cv))
2601                 goto temporise_array;
2602             EXTEND_MORTAL(SP - newsp);
2603             for (mark = newsp + 1; mark <= SP; mark++) {
2604                 if (SvTEMP(*mark))
2605                     NOOP;
2606                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2607                     *mark = sv_mortalcopy(*mark);
2608                 else {
2609                     /* Can be a localized value subject to deletion. */
2610                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2611                     SvREFCNT_inc_void(*mark);
2612                 }
2613             }
2614         }
2615     }
2616     else if (CxLVAL(cx)) {     /* Leave it as it is if we can. */
2617         /* Here we go for robustness, not for speed, so we change all
2618          * the refcounts so the caller gets a live guy. Cannot set
2619          * TEMP, so sv_2mortal is out of question. */
2620         if (!CvLVALUE(cx->blk_sub.cv)) {
2621             LEAVE;
2622             cxstack_ix--;
2623             POPSUB(cx,sv);
2624             PL_curpm = newpm;
2625             LEAVESUB(sv);
2626             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2627         }
2628         if (gimme == G_SCALAR) {
2629             MARK = newsp + 1;
2630             EXTEND_MORTAL(1);
2631             if (MARK == SP) {
2632                 /* Temporaries are bad unless they happen to have set magic
2633                  * attached, such as the elements of a tied hash or array */
2634                 if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
2635                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2636                        == SVf_READONLY
2637                     ) &&
2638                     !SvSMAGICAL(TOPs)) {
2639                     LEAVE;
2640                     cxstack_ix--;
2641                     POPSUB(cx,sv);
2642                     PL_curpm = newpm;
2643                     LEAVESUB(sv);
2644                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2645                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2646                         : "a readonly value" : "a temporary");
2647                 }
2648                 else {                  /* Can be a localized value
2649                                          * subject to deletion. */
2650                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2651                     SvREFCNT_inc_void(*mark);
2652                 }
2653             }
2654             else {                      /* Should not happen? */
2655                 LEAVE;
2656                 cxstack_ix--;
2657                 POPSUB(cx,sv);
2658                 PL_curpm = newpm;
2659                 LEAVESUB(sv);
2660                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2661                     (MARK > SP ? "Empty array" : "Array"));
2662             }
2663             SP = MARK;
2664         }
2665         else if (gimme == G_ARRAY) {
2666             EXTEND_MORTAL(SP - newsp);
2667             for (mark = newsp + 1; mark <= SP; mark++) {
2668                 if (*mark != &PL_sv_undef
2669                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2670                     /* Might be flattened array after $#array =  */
2671                     PUTBACK;
2672                     LEAVE;
2673                     cxstack_ix--;
2674                     POPSUB(cx,sv);
2675                     PL_curpm = newpm;
2676                     LEAVESUB(sv);
2677                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2678                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2679                 }
2680                 else {
2681                     /* Can be a localized value subject to deletion. */
2682                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2683                     SvREFCNT_inc_void(*mark);
2684                 }
2685             }
2686         }
2687     }
2688     else {
2689         if (gimme == G_SCALAR) {
2690           temporise:
2691             MARK = newsp + 1;
2692             if (MARK <= SP) {
2693                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2694                     if (SvTEMP(TOPs)) {
2695                         *MARK = SvREFCNT_inc(TOPs);
2696                         FREETMPS;
2697                         sv_2mortal(*MARK);
2698                     }
2699                     else {
2700                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2701                         FREETMPS;
2702                         *MARK = sv_mortalcopy(sv);
2703                         SvREFCNT_dec(sv);
2704                     }
2705                 }
2706                 else
2707                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2708             }
2709             else {
2710                 MEXTEND(MARK, 0);
2711                 *MARK = &PL_sv_undef;
2712             }
2713             SP = MARK;
2714         }
2715         else if (gimme == G_ARRAY) {
2716           temporise_array:
2717             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2718                 if (!SvTEMP(*MARK)) {
2719                     *MARK = sv_mortalcopy(*MARK);
2720                     TAINT_NOT;  /* Each item is independent */
2721                 }
2722             }
2723         }
2724     }
2725     PUTBACK;
2726
2727     LEAVE;
2728     cxstack_ix--;
2729     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2730     PL_curpm = newpm;   /* ... and pop $1 et al */
2731
2732     LEAVESUB(sv);
2733     return cx->blk_sub.retop;
2734 }
2735
2736 PP(pp_entersub)
2737 {
2738     dVAR; dSP; dPOPss;
2739     GV *gv;
2740     register CV *cv;
2741     register PERL_CONTEXT *cx;
2742     I32 gimme;
2743     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2744
2745     if (!sv)
2746         DIE(aTHX_ "Not a CODE reference");
2747     switch (SvTYPE(sv)) {
2748         /* This is overwhelming the most common case:  */
2749     case SVt_PVGV:
2750         if (!isGV_with_GP(sv))
2751             DIE(aTHX_ "Not a CODE reference");
2752       we_have_a_glob:
2753         if (!(cv = GvCVu((const GV *)sv))) {
2754             HV *stash;
2755             cv = sv_2cv(sv, &stash, &gv, 0);
2756         }
2757         if (!cv) {
2758             ENTER;
2759             SAVETMPS;
2760             goto try_autoload;
2761         }
2762         break;
2763     case SVt_PVLV:
2764         if(isGV_with_GP(sv)) goto we_have_a_glob;
2765         /*FALLTHROUGH*/
2766     default:
2767         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2768             if (hasargs)
2769                 SP = PL_stack_base + POPMARK;
2770             RETURN;
2771         }
2772         SvGETMAGIC(sv);
2773         if (SvROK(sv)) {
2774             SV * const * sp = &sv;      /* Used in tryAMAGICunDEREF macro. */
2775             tryAMAGICunDEREF(to_cv);
2776         }
2777         else {
2778             const char *sym;
2779             STRLEN len;
2780             sym = SvPV_nomg_const(sv, len);
2781             if (!sym)
2782                 DIE(aTHX_ PL_no_usym, "a subroutine");
2783             if (PL_op->op_private & HINT_STRICT_REFS)
2784                 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2785             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2786             break;
2787         }
2788         cv = MUTABLE_CV(SvRV(sv));
2789         if (SvTYPE(cv) == SVt_PVCV)
2790             break;
2791         /* FALL THROUGH */
2792     case SVt_PVHV:
2793     case SVt_PVAV:
2794         DIE(aTHX_ "Not a CODE reference");
2795         /* This is the second most common case:  */
2796     case SVt_PVCV:
2797         cv = MUTABLE_CV(sv);
2798         break;
2799     }
2800
2801     ENTER;
2802     SAVETMPS;
2803
2804   retry:
2805     if (!CvROOT(cv) && !CvXSUB(cv)) {
2806         GV* autogv;
2807         SV* sub_name;
2808
2809         /* anonymous or undef'd function leaves us no recourse */
2810         if (CvANON(cv) || !(gv = CvGV(cv)))
2811             DIE(aTHX_ "Undefined subroutine called");
2812
2813         /* autoloaded stub? */
2814         if (cv != GvCV(gv)) {
2815             cv = GvCV(gv);
2816         }
2817         /* should call AUTOLOAD now? */
2818         else {
2819 try_autoload:
2820             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2821                                    FALSE)))
2822             {
2823                 cv = GvCV(autogv);
2824             }
2825             /* sorry */
2826             else {
2827                 sub_name = sv_newmortal();
2828                 gv_efullname3(sub_name, gv, NULL);
2829                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2830             }
2831         }
2832         if (!cv)
2833             DIE(aTHX_ "Not a CODE reference");
2834         goto retry;
2835     }
2836
2837     gimme = GIMME_V;
2838     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2839          Perl_get_db_sub(aTHX_ &sv, cv);
2840          if (CvISXSUB(cv))
2841              PL_curcopdb = PL_curcop;
2842          if (CvLVALUE(cv)) {
2843              /* check for lsub that handles lvalue subroutines */
2844              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2845              /* if lsub not found then fall back to DB::sub */
2846              if (!cv) cv = GvCV(PL_DBsub);
2847          } else {
2848              cv = GvCV(PL_DBsub);
2849          }
2850
2851         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2852             DIE(aTHX_ "No DB::sub routine defined");
2853     }
2854
2855     if (!(CvISXSUB(cv))) {
2856         /* This path taken at least 75% of the time   */
2857         dMARK;
2858         register I32 items = SP - MARK;
2859         AV* const padlist = CvPADLIST(cv);
2860         PUSHBLOCK(cx, CXt_SUB, MARK);
2861         PUSHSUB(cx);
2862         cx->blk_sub.retop = PL_op->op_next;
2863         CvDEPTH(cv)++;
2864         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2865          * that eval'' ops within this sub know the correct lexical space.
2866          * Owing the speed considerations, we choose instead to search for
2867          * the cv using find_runcv() when calling doeval().
2868          */
2869         if (CvDEPTH(cv) >= 2) {
2870             PERL_STACK_OVERFLOW_CHECK();
2871             pad_push(padlist, CvDEPTH(cv));
2872         }
2873         SAVECOMPPAD();
2874         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2875         if (hasargs) {
2876             AV *const av = MUTABLE_AV(PAD_SVl(0));
2877             if (AvREAL(av)) {
2878                 /* @_ is normally not REAL--this should only ever
2879                  * happen when DB::sub() calls things that modify @_ */
2880                 av_clear(av);
2881                 AvREAL_off(av);
2882                 AvREIFY_on(av);
2883             }
2884             cx->blk_sub.savearray = GvAV(PL_defgv);
2885             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2886             CX_CURPAD_SAVE(cx->blk_sub);
2887             cx->blk_sub.argarray = av;
2888             ++MARK;
2889
2890             if (items > AvMAX(av) + 1) {
2891                 SV **ary = AvALLOC(av);
2892                 if (AvARRAY(av) != ary) {
2893                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2894                     AvARRAY(av) = ary;
2895                 }
2896                 if (items > AvMAX(av) + 1) {
2897                     AvMAX(av) = items - 1;
2898                     Renew(ary,items,SV*);
2899                     AvALLOC(av) = ary;
2900                     AvARRAY(av) = ary;
2901                 }
2902             }
2903             Copy(MARK,AvARRAY(av),items,SV*);
2904             AvFILLp(av) = items - 1;
2905
2906             while (items--) {
2907                 if (*MARK)
2908                     SvTEMP_off(*MARK);
2909                 MARK++;
2910             }
2911         }
2912         /* warning must come *after* we fully set up the context
2913          * stuff so that __WARN__ handlers can safely dounwind()
2914          * if they want to
2915          */
2916         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2917             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2918             sub_crush_depth(cv);
2919         RETURNOP(CvSTART(cv));
2920     }
2921     else {
2922         I32 markix = TOPMARK;
2923
2924         PUTBACK;
2925
2926         if (!hasargs) {
2927             /* Need to copy @_ to stack. Alternative may be to
2928              * switch stack to @_, and copy return values
2929              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2930             AV * const av = GvAV(PL_defgv);
2931             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2932
2933             if (items) {
2934                 /* Mark is at the end of the stack. */
2935                 EXTEND(SP, items);
2936                 Copy(AvARRAY(av), SP + 1, items, SV*);
2937                 SP += items;
2938                 PUTBACK ;
2939             }
2940         }
2941         /* We assume first XSUB in &DB::sub is the called one. */
2942         if (PL_curcopdb) {
2943             SAVEVPTR(PL_curcop);
2944             PL_curcop = PL_curcopdb;
2945             PL_curcopdb = NULL;
2946         }
2947         /* Do we need to open block here? XXXX */
2948
2949         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2950         assert(CvXSUB(cv));
2951         CvXSUB(cv)(aTHX_ cv);
2952
2953         /* Enforce some sanity in scalar context. */
2954         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2955             if (markix > PL_stack_sp - PL_stack_base)
2956                 *(PL_stack_base + markix) = &PL_sv_undef;
2957             else
2958                 *(PL_stack_base + markix) = *PL_stack_sp;
2959             PL_stack_sp = PL_stack_base + markix;
2960         }
2961         LEAVE;
2962         return NORMAL;
2963     }
2964 }
2965
2966 void
2967 Perl_sub_crush_depth(pTHX_ CV *cv)
2968 {
2969     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2970
2971     if (CvANON(cv))
2972         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2973     else {
2974         SV* const tmpstr = sv_newmortal();
2975         gv_efullname3(tmpstr, CvGV(cv), NULL);
2976         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2977                     SVfARG(tmpstr));
2978     }
2979 }
2980
2981 PP(pp_aelem)
2982 {
2983     dVAR; dSP;
2984     SV** svp;
2985     SV* const elemsv = POPs;
2986     IV elem = SvIV(elemsv);
2987     AV *const av = MUTABLE_AV(POPs);
2988     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2989     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2990     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2991     bool preeminent = TRUE;
2992     SV *sv;
2993
2994     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2995         Perl_warner(aTHX_ packWARN(WARN_MISC),
2996                     "Use of reference \"%"SVf"\" as array index",
2997                     SVfARG(elemsv));
2998     if (elem > 0)
2999         elem -= CopARYBASE_get(PL_curcop);
3000     if (SvTYPE(av) != SVt_PVAV)
3001         RETPUSHUNDEF;
3002
3003     if (localizing) {
3004         MAGIC *mg;
3005         HV *stash;
3006
3007         /* If we can determine whether the element exist,
3008          * Try to preserve the existenceness of a tied array
3009          * element by using EXISTS and DELETE if possible.
3010          * Fallback to FETCH and STORE otherwise. */
3011         if (SvCANEXISTDELETE(av))
3012             preeminent = av_exists(av, elem);
3013     }
3014
3015     svp = av_fetch(av, elem, lval && !defer);
3016     if (lval) {
3017 #ifdef PERL_MALLOC_WRAP
3018          if (SvUOK(elemsv)) {
3019               const UV uv = SvUV(elemsv);
3020               elem = uv > IV_MAX ? IV_MAX : uv;
3021          }
3022          else if (SvNOK(elemsv))
3023               elem = (IV)SvNV(elemsv);
3024          if (elem > 0) {
3025               static const char oom_array_extend[] =
3026                 "Out of memory during array extend"; /* Duplicated in av.c */
3027               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3028          }
3029 #endif
3030         if (!svp || *svp == &PL_sv_undef) {
3031             SV* lv;
3032             if (!defer)
3033                 DIE(aTHX_ PL_no_aelem, elem);
3034             lv = sv_newmortal();
3035             sv_upgrade(lv, SVt_PVLV);
3036             LvTYPE(lv) = 'y';
3037             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3038             LvTARG(lv) = SvREFCNT_inc_simple(av);
3039             LvTARGOFF(lv) = elem;
3040             LvTARGLEN(lv) = 1;
3041             PUSHs(lv);
3042             RETURN;
3043         }
3044         if (localizing) {
3045             if (preeminent)
3046                 save_aelem(av, elem, svp);
3047             else
3048                 SAVEADELETE(av, elem);
3049         }
3050         else if (PL_op->op_private & OPpDEREF)
3051             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3052     }
3053     sv = (svp ? *svp : &PL_sv_undef);
3054     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3055         mg_get(sv);
3056     PUSHs(sv);
3057     RETURN;
3058 }
3059
3060 void
3061 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3062 {
3063     PERL_ARGS_ASSERT_VIVIFY_REF;
3064
3065     SvGETMAGIC(sv);
3066     if (!SvOK(sv)) {
3067         if (SvREADONLY(sv))
3068             Perl_croak_no_modify(aTHX);
3069         prepare_SV_for_RV(sv);
3070         switch (to_what) {
3071         case OPpDEREF_SV:
3072             SvRV_set(sv, newSV(0));
3073             break;
3074         case OPpDEREF_AV:
3075             SvRV_set(sv, MUTABLE_SV(newAV()));
3076             break;
3077         case OPpDEREF_HV:
3078             SvRV_set(sv, MUTABLE_SV(newHV()));
3079             break;
3080         }
3081         SvROK_on(sv);
3082         SvSETMAGIC(sv);
3083     }
3084 }
3085
3086 PP(pp_method)
3087 {
3088     dVAR; dSP;
3089     SV* const sv = TOPs;
3090
3091     if (SvROK(sv)) {
3092         SV* const rsv = SvRV(sv);
3093         if (SvTYPE(rsv) == SVt_PVCV) {
3094             SETs(rsv);
3095             RETURN;
3096         }
3097     }
3098
3099     SETs(method_common(sv, NULL));
3100     RETURN;
3101 }
3102
3103 PP(pp_method_named)
3104 {
3105     dVAR; dSP;
3106     SV* const sv = cSVOP_sv;
3107     U32 hash = SvSHARED_HASH(sv);
3108
3109     XPUSHs(method_common(sv, &hash));
3110     RETURN;
3111 }
3112
3113 STATIC SV *
3114 S_method_common(pTHX_ SV* meth, U32* hashp)
3115 {
3116     dVAR;
3117     SV* ob;
3118     GV* gv;
3119     HV* stash;
3120     const char* packname = NULL;
3121     SV *packsv = NULL;
3122     STRLEN packlen;
3123     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3124
3125     PERL_ARGS_ASSERT_METHOD_COMMON;
3126
3127     if (!sv)
3128         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3129                    SVfARG(meth));
3130
3131     SvGETMAGIC(sv);
3132     if (SvROK(sv))
3133         ob = MUTABLE_SV(SvRV(sv));
3134     else {
3135         GV* iogv;
3136
3137         /* this isn't a reference */
3138         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3139           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3140           if (he) {
3141             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3142             goto fetch;
3143           }
3144         }
3145
3146         if (!SvOK(sv) ||
3147             !(packname) ||
3148             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3149             !(ob=MUTABLE_SV(GvIO(iogv))))
3150         {
3151             /* this isn't the name of a filehandle either */
3152             if (!packname ||
3153                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3154                     ? !isIDFIRST_utf8((U8*)packname)
3155                     : !isIDFIRST(*packname)
3156                 ))
3157             {
3158                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3159                            SVfARG(meth),
3160                            SvOK(sv) ? "without a package or object reference"
3161                                     : "on an undefined value");
3162             }
3163             /* assume it's a package name */
3164             stash = gv_stashpvn(packname, packlen, 0);
3165             if (!stash)
3166                 packsv = sv;
3167             else {
3168                 SV* const ref = newSViv(PTR2IV(stash));
3169                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3170             }
3171             goto fetch;
3172         }
3173         /* it _is_ a filehandle name -- replace with a reference */
3174         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3175     }
3176
3177     /* if we got here, ob should be a reference or a glob */
3178     if (!ob || !(SvOBJECT(ob)
3179                  || (SvTYPE(ob) == SVt_PVGV
3180                      && isGV_with_GP(ob)
3181                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3182                      && SvOBJECT(ob))))
3183     {
3184         const char * const name = SvPV_nolen_const(meth);
3185         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3186                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3187                    name);
3188     }
3189
3190     stash = SvSTASH(ob);
3191
3192   fetch:
3193     /* NOTE: stash may be null, hope hv_fetch_ent and
3194        gv_fetchmethod can cope (it seems they can) */
3195
3196     /* shortcut for simple names */
3197     if (hashp) {
3198         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3199         if (he) {
3200             gv = MUTABLE_GV(HeVAL(he));
3201             if (isGV(gv) && GvCV(gv) &&
3202                 (!GvCVGEN(gv) || GvCVGEN(gv)
3203                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3204                 return MUTABLE_SV(GvCV(gv));
3205         }
3206     }
3207
3208     gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3209                               SvPV_nolen_const(meth),
3210                               GV_AUTOLOAD | GV_CROAK);
3211
3212     assert(gv);
3213
3214     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3215 }
3216
3217 /*
3218  * Local variables:
3219  * c-indentation-style: bsd
3220  * c-basic-offset: 4
3221  * indent-tabs-mode: t
3222  * End:
3223  *
3224  * ex: set ts=8 sts=4 sw=4 noet:
3225  */