pp_hot.c

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