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         if (!matched)
2228         {
2229             SPAGAIN;
2230             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2231                 PUSHs(TARG);
2232             else
2233                 PUSHs(&PL_sv_no);
2234             LEAVE_SCOPE(oldsave);
2235             RETURN;
2236         }
2237 #ifdef PERL_OLD_COPY_ON_WRITE
2238         if (SvIsCOW(TARG)) {
2239             assert (!force_on_match);
2240             goto have_a_cow;
2241         }
2242 #endif
2243         if (force_on_match) {
2244             force_on_match = 0;
2245             s = SvPV_force(TARG, len);
2246             goto force_it;
2247         }
2248         d = s;
2249         PL_curpm = pm;
2250         SvSCREAM_off(TARG);     /* disable possible screamer */
2251         if (once) {
2252             rxtainted |= RX_MATCH_TAINTED(rx);
2253             m = orig + RX_OFFS(rx)[0].start;
2254             d = orig + RX_OFFS(rx)[0].end;
2255             s = orig;
2256             if (m - s > strend - d) {  /* faster to shorten from end */
2257                 if (clen) {
2258                     Copy(c, m, clen, char);
2259                     m += clen;
2260                 }
2261                 i = strend - d;
2262                 if (i > 0) {
2263                     Move(d, m, i, char);
2264                     m += i;
2265                 }
2266                 *m = '\0';
2267                 SvCUR_set(TARG, m - s);
2268             }
2269             else if ((i = m - s)) {     /* faster from front */
2270                 d -= clen;
2271                 m = d;
2272                 Move(s, d - i, i, char);
2273                 sv_chop(TARG, d-i);
2274                 if (clen)
2275                     Copy(c, m, clen, char);
2276             }
2277             else if (clen) {
2278                 d -= clen;
2279                 sv_chop(TARG, d);
2280                 Copy(c, d, clen, char);
2281             }
2282             else {
2283                 sv_chop(TARG, d);
2284             }
2285             TAINT_IF(rxtainted & 1);
2286             SPAGAIN;
2287             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2288                 PUSHs(TARG);
2289             else
2290                 PUSHs(&PL_sv_yes);
2291         }
2292         else {
2293             do {
2294                 if (iters++ > maxiters)
2295                     DIE(aTHX_ "Substitution loop");
2296                 rxtainted |= RX_MATCH_TAINTED(rx);
2297                 m = RX_OFFS(rx)[0].start + orig;
2298                 if ((i = m - s)) {
2299                     if (s != d)
2300                         Move(s, d, i, char);
2301                     d += i;
2302                 }
2303                 if (clen) {
2304                     Copy(c, d, clen, char);
2305                     d += clen;
2306                 }
2307                 s = RX_OFFS(rx)[0].end + orig;
2308             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2309                                  TARG, NULL,
2310                                  /* don't match same null twice */
2311                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2312             if (s != d) {
2313                 i = strend - s;
2314                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2315                 Move(s, d, i+1, char);          /* include the NUL */
2316             }
2317             TAINT_IF(rxtainted & 1);
2318             SPAGAIN;
2319             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2320                 PUSHs(TARG);
2321             else
2322                 mPUSHi((I32)iters);
2323         }
2324         (void)SvPOK_only_UTF8(TARG);
2325         TAINT_IF(rxtainted);
2326         if (SvSMAGICAL(TARG)) {
2327             PUTBACK;
2328             mg_set(TARG);
2329             SPAGAIN;
2330         }
2331         SvTAINT(TARG);
2332         if (doutf8)
2333             SvUTF8_on(TARG);
2334         LEAVE_SCOPE(oldsave);
2335         RETURN;
2336     }
2337
2338     if (matched)
2339     {
2340         if (force_on_match) {
2341             force_on_match = 0;
2342             s = SvPV_force(TARG, len);
2343             goto force_it;
2344         }
2345 #ifdef PERL_OLD_COPY_ON_WRITE
2346       have_a_cow:
2347 #endif
2348         rxtainted |= RX_MATCH_TAINTED(rx);
2349         dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2350         SAVEFREESV(dstr);
2351         PL_curpm = pm;
2352         if (!c) {
2353             register PERL_CONTEXT *cx;
2354             SPAGAIN;
2355             PUSHSUBST(cx);
2356             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2357         }
2358         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2359         do {
2360             if (iters++ > maxiters)
2361                 DIE(aTHX_ "Substitution loop");
2362             rxtainted |= RX_MATCH_TAINTED(rx);
2363             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2364                 m = s;
2365                 s = orig;
2366                 orig = RX_SUBBEG(rx);
2367                 s = orig + (m - s);
2368                 strend = s + (strend - m);
2369             }
2370             m = RX_OFFS(rx)[0].start + orig;
2371             if (doutf8 && !SvUTF8(dstr))
2372                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2373             else
2374                 sv_catpvn(dstr, s, m-s);
2375             s = RX_OFFS(rx)[0].end + orig;
2376             if (clen)
2377                 sv_catpvn(dstr, c, clen);
2378             if (once)
2379                 break;
2380         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2381                              TARG, NULL, r_flags));
2382         if (doutf8 && !DO_UTF8(TARG))
2383             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2384         else
2385             sv_catpvn(dstr, s, strend - s);
2386
2387 #ifdef PERL_OLD_COPY_ON_WRITE
2388         /* The match may make the string COW. If so, brilliant, because that's
2389            just saved us one malloc, copy and free - the regexp has donated
2390            the old buffer, and we malloc an entirely new one, rather than the
2391            regexp malloc()ing a buffer and copying our original, only for
2392            us to throw it away here during the substitution.  */
2393         if (SvIsCOW(TARG)) {
2394             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2395         } else
2396 #endif
2397         {
2398             SvPV_free(TARG);
2399         }
2400         SvPV_set(TARG, SvPVX(dstr));
2401         SvCUR_set(TARG, SvCUR(dstr));
2402         SvLEN_set(TARG, SvLEN(dstr));
2403         doutf8 |= DO_UTF8(dstr);
2404         SvPV_set(dstr, NULL);
2405
2406         TAINT_IF(rxtainted & 1);
2407         SPAGAIN;
2408         if (rpm->op_pmflags & PMf_NONDESTRUCT)
2409             PUSHs(TARG);
2410         else
2411             mPUSHi((I32)iters);
2412
2413         (void)SvPOK_only(TARG);
2414         if (doutf8)
2415             SvUTF8_on(TARG);
2416         TAINT_IF(rxtainted);
2417         SvSETMAGIC(TARG);
2418         SvTAINT(TARG);
2419         LEAVE_SCOPE(oldsave);
2420         RETURN;
2421     }
2422     goto ret_no;
2423
2424 nope:
2425 ret_no:
2426     SPAGAIN;
2427     if (rpm->op_pmflags & PMf_NONDESTRUCT)
2428         PUSHs(TARG);
2429     else
2430         PUSHs(&PL_sv_no);
2431     LEAVE_SCOPE(oldsave);
2432     RETURN;
2433 }
2434
2435 PP(pp_grepwhile)
2436 {
2437     dVAR; dSP;
2438
2439     if (SvTRUEx(POPs))
2440         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2441     ++*PL_markstack_ptr;
2442     FREETMPS;
2443     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2444
2445     /* All done yet? */
2446     if (PL_stack_base + *PL_markstack_ptr > SP) {
2447         I32 items;
2448         const I32 gimme = GIMME_V;
2449
2450         LEAVE_with_name("grep");                                        /* exit outer scope */
2451         (void)POPMARK;                          /* pop src */
2452         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2453         (void)POPMARK;                          /* pop dst */
2454         SP = PL_stack_base + POPMARK;           /* pop original mark */
2455         if (gimme == G_SCALAR) {
2456             if (PL_op->op_private & OPpGREP_LEX) {
2457                 SV* const sv = sv_newmortal();
2458                 sv_setiv(sv, items);
2459                 PUSHs(sv);
2460             }
2461             else {
2462                 dTARGET;
2463                 XPUSHi(items);
2464             }
2465         }
2466         else if (gimme == G_ARRAY)
2467             SP += items;
2468         RETURN;
2469     }
2470     else {
2471         SV *src;
2472
2473         ENTER_with_name("grep_item");                                   /* enter inner scope */
2474         SAVEVPTR(PL_curpm);
2475
2476         src = PL_stack_base[*PL_markstack_ptr];
2477         SvTEMP_off(src);
2478         if (PL_op->op_private & OPpGREP_LEX)
2479             PAD_SVl(PL_op->op_targ) = src;
2480         else
2481             DEFSV_set(src);
2482
2483         RETURNOP(cLOGOP->op_other);
2484     }
2485 }
2486
2487 PP(pp_leavesub)
2488 {
2489     dVAR; dSP;
2490     SV **mark;
2491     SV **newsp;
2492     PMOP *newpm;
2493     I32 gimme;
2494     register PERL_CONTEXT *cx;
2495     SV *sv;
2496
2497     if (CxMULTICALL(&cxstack[cxstack_ix]))
2498         return 0;
2499
2500     POPBLOCK(cx,newpm);
2501     cxstack_ix++; /* temporarily protect top context */
2502
2503     TAINT_NOT;
2504     if (gimme == G_SCALAR) {
2505         MARK = newsp + 1;
2506         if (MARK <= SP) {
2507             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2508                 if (SvTEMP(TOPs)) {
2509                     *MARK = SvREFCNT_inc(TOPs);
2510                     FREETMPS;
2511                     sv_2mortal(*MARK);
2512                 }
2513                 else {
2514                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2515                     FREETMPS;
2516                     *MARK = sv_mortalcopy(sv);
2517                     SvREFCNT_dec(sv);
2518                 }
2519             }
2520             else
2521                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2522         }
2523         else {
2524             MEXTEND(MARK, 0);
2525             *MARK = &PL_sv_undef;
2526         }
2527         SP = MARK;
2528     }
2529     else if (gimme == G_ARRAY) {
2530         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2531             if (!SvTEMP(*MARK)) {
2532                 *MARK = sv_mortalcopy(*MARK);
2533                 TAINT_NOT;      /* Each item is independent */
2534             }
2535         }
2536     }
2537     PUTBACK;
2538
2539     LEAVE;
2540     cxstack_ix--;
2541     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2542     PL_curpm = newpm;   /* ... and pop $1 et al */
2543
2544     LEAVESUB(sv);
2545     return cx->blk_sub.retop;
2546 }
2547
2548 /* This duplicates the above code because the above code must not
2549  * get any slower by more conditions */
2550 PP(pp_leavesublv)
2551 {
2552     dVAR; dSP;
2553     SV **mark;
2554     SV **newsp;
2555     PMOP *newpm;
2556     I32 gimme;
2557     register PERL_CONTEXT *cx;
2558     SV *sv;
2559
2560     if (CxMULTICALL(&cxstack[cxstack_ix]))
2561         return 0;
2562
2563     POPBLOCK(cx,newpm);
2564     cxstack_ix++; /* temporarily protect top context */
2565
2566     TAINT_NOT;
2567
2568     if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2569         /* We are an argument to a function or grep().
2570          * This kind of lvalueness was legal before lvalue
2571          * subroutines too, so be backward compatible:
2572          * cannot report errors.  */
2573
2574         /* Scalar context *is* possible, on the LHS of -> only,
2575          * as in f()->meth().  But this is not an lvalue. */
2576         if (gimme == G_SCALAR)
2577             goto temporise;
2578         if (gimme == G_ARRAY) {
2579             mark = newsp + 1;
2580             /* We want an array here, but padav will have left us an arrayref for an lvalue,
2581              * so we need to expand it */
2582             if(SvTYPE(*mark) == SVt_PVAV) {
2583                 AV *const av = MUTABLE_AV(*mark);
2584                 const I32 maxarg = AvFILL(av) + 1;
2585                 (void)POPs; /* get rid of the array ref */
2586                 EXTEND(SP, maxarg);
2587                 if (SvRMAGICAL(av)) {
2588                     U32 i;
2589                     for (i=0; i < (U32)maxarg; i++) {
2590                         SV ** const svp = av_fetch(av, i, FALSE);
2591                         SP[i+1] = svp
2592                             ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
2593                             : &PL_sv_undef;
2594                     }
2595                 }
2596                 else {
2597                     Copy(AvARRAY(av), SP+1, maxarg, SV*);
2598                 }
2599                 SP += maxarg;
2600                 PUTBACK;
2601             }
2602             if (!CvLVALUE(cx->blk_sub.cv))
2603                 goto temporise_array;
2604             EXTEND_MORTAL(SP - newsp);
2605             for (mark = newsp + 1; mark <= SP; mark++) {
2606                 if (SvTEMP(*mark))
2607                     NOOP;
2608                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2609                     *mark = sv_mortalcopy(*mark);
2610                 else {
2611                     /* Can be a localized value subject to deletion. */
2612                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2613                     SvREFCNT_inc_void(*mark);
2614                 }
2615             }
2616         }
2617     }
2618     else if (CxLVAL(cx)) {     /* Leave it as it is if we can. */
2619         /* Here we go for robustness, not for speed, so we change all
2620          * the refcounts so the caller gets a live guy. Cannot set
2621          * TEMP, so sv_2mortal is out of question. */
2622         if (!CvLVALUE(cx->blk_sub.cv)) {
2623             LEAVE;
2624             cxstack_ix--;
2625             POPSUB(cx,sv);
2626             PL_curpm = newpm;
2627             LEAVESUB(sv);
2628             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2629         }
2630         if (gimme == G_SCALAR) {
2631             MARK = newsp + 1;
2632             EXTEND_MORTAL(1);
2633             if (MARK == SP) {
2634                 /* Temporaries are bad unless they happen to have set magic
2635                  * attached, such as the elements of a tied hash or array */
2636                 if ((SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP) ||
2637                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2638                        == SVf_READONLY
2639                     ) &&
2640                     !SvSMAGICAL(TOPs)) {
2641                     LEAVE;
2642                     cxstack_ix--;
2643                     POPSUB(cx,sv);
2644                     PL_curpm = newpm;
2645                     LEAVESUB(sv);
2646                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2647                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2648                         : "a readonly value" : "a temporary");
2649                 }
2650                 else {                  /* Can be a localized value
2651                                          * subject to deletion. */
2652                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2653                     SvREFCNT_inc_void(*mark);
2654                 }
2655             }
2656             else {                      /* Should not happen? */
2657                 LEAVE;
2658                 cxstack_ix--;
2659                 POPSUB(cx,sv);
2660                 PL_curpm = newpm;
2661                 LEAVESUB(sv);
2662                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2663                     (MARK > SP ? "Empty array" : "Array"));
2664             }
2665             SP = MARK;
2666         }
2667         else if (gimme == G_ARRAY) {
2668             EXTEND_MORTAL(SP - newsp);
2669             for (mark = newsp + 1; mark <= SP; mark++) {
2670                 if (*mark != &PL_sv_undef
2671                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2672                     /* Might be flattened array after $#array =  */
2673                     PUTBACK;
2674                     LEAVE;
2675                     cxstack_ix--;
2676                     POPSUB(cx,sv);
2677                     PL_curpm = newpm;
2678                     LEAVESUB(sv);
2679                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2680                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2681                 }
2682                 else {
2683                     /* Can be a localized value subject to deletion. */
2684                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2685                     SvREFCNT_inc_void(*mark);
2686                 }
2687             }
2688         }
2689     }
2690     else {
2691         if (gimme == G_SCALAR) {
2692           temporise:
2693             MARK = newsp + 1;
2694             if (MARK <= SP) {
2695                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2696                     if (SvTEMP(TOPs)) {
2697                         *MARK = SvREFCNT_inc(TOPs);
2698                         FREETMPS;
2699                         sv_2mortal(*MARK);
2700                     }
2701                     else {
2702                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2703                         FREETMPS;
2704                         *MARK = sv_mortalcopy(sv);
2705                         SvREFCNT_dec(sv);
2706                     }
2707                 }
2708                 else
2709                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2710             }
2711             else {
2712                 MEXTEND(MARK, 0);
2713                 *MARK = &PL_sv_undef;
2714             }
2715             SP = MARK;
2716         }
2717         else if (gimme == G_ARRAY) {
2718           temporise_array:
2719             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2720                 if (!SvTEMP(*MARK)) {
2721                     *MARK = sv_mortalcopy(*MARK);
2722                     TAINT_NOT;  /* Each item is independent */
2723                 }
2724             }
2725         }
2726     }
2727     PUTBACK;
2728
2729     LEAVE;
2730     cxstack_ix--;
2731     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2732     PL_curpm = newpm;   /* ... and pop $1 et al */
2733
2734     LEAVESUB(sv);
2735     return cx->blk_sub.retop;
2736 }
2737
2738 PP(pp_entersub)
2739 {
2740     dVAR; dSP; dPOPss;
2741     GV *gv;
2742     register CV *cv;
2743     register PERL_CONTEXT *cx;
2744     I32 gimme;
2745     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2746
2747     if (!sv)
2748         DIE(aTHX_ "Not a CODE reference");
2749     switch (SvTYPE(sv)) {
2750         /* This is overwhelming the most common case:  */
2751     case SVt_PVGV:
2752         if (!isGV_with_GP(sv))
2753             DIE(aTHX_ "Not a CODE reference");
2754       we_have_a_glob:
2755         if (!(cv = GvCVu((const GV *)sv))) {
2756             HV *stash;
2757             cv = sv_2cv(sv, &stash, &gv, 0);
2758         }
2759         if (!cv) {
2760             ENTER;
2761             SAVETMPS;
2762             goto try_autoload;
2763         }
2764         break;
2765     case SVt_PVLV:
2766         if(isGV_with_GP(sv)) goto we_have_a_glob;
2767         /*FALLTHROUGH*/
2768     default:
2769         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2770             if (hasargs)
2771                 SP = PL_stack_base + POPMARK;
2772             else
2773                 (void)POPMARK;
2774             RETURN;
2775         }
2776         SvGETMAGIC(sv);
2777         if (SvROK(sv)) {
2778             if (SvAMAGIC(sv)) {
2779                 sv = amagic_deref_call(sv, to_cv_amg);
2780                 /* Don't SPAGAIN here.  */
2781             }
2782         }
2783         else {
2784             const char *sym;
2785             STRLEN len;
2786             sym = SvPV_nomg_const(sv, len);
2787             if (!sym)
2788                 DIE(aTHX_ PL_no_usym, "a subroutine");
2789             if (PL_op->op_private & HINT_STRICT_REFS)
2790                 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2791             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2792             break;
2793         }
2794         cv = MUTABLE_CV(SvRV(sv));
2795         if (SvTYPE(cv) == SVt_PVCV)
2796             break;
2797         /* FALL THROUGH */
2798     case SVt_PVHV:
2799     case SVt_PVAV:
2800         DIE(aTHX_ "Not a CODE reference");
2801         /* This is the second most common case:  */
2802     case SVt_PVCV:
2803         cv = MUTABLE_CV(sv);
2804         break;
2805     }
2806
2807     ENTER;
2808     SAVETMPS;
2809
2810   retry:
2811     if (CvCLONE(cv) && ! CvCLONED(cv))
2812         DIE(aTHX_ "Closure prototype called");
2813     if (!CvROOT(cv) && !CvXSUB(cv)) {
2814         GV* autogv;
2815         SV* sub_name;
2816
2817         /* anonymous or undef'd function leaves us no recourse */
2818         if (CvANON(cv) || !(gv = CvGV(cv)))
2819             DIE(aTHX_ "Undefined subroutine called");
2820
2821         /* autoloaded stub? */
2822         if (cv != GvCV(gv)) {
2823             cv = GvCV(gv);
2824         }
2825         /* should call AUTOLOAD now? */
2826         else {
2827 try_autoload:
2828             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2829                                    FALSE)))
2830             {
2831                 cv = GvCV(autogv);
2832             }
2833             /* sorry */
2834             else {
2835                 sub_name = sv_newmortal();
2836                 gv_efullname3(sub_name, gv, NULL);
2837                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2838             }
2839         }
2840         if (!cv)
2841             DIE(aTHX_ "Not a CODE reference");
2842         goto retry;
2843     }
2844
2845     gimme = GIMME_V;
2846     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2847          Perl_get_db_sub(aTHX_ &sv, cv);
2848          if (CvISXSUB(cv))
2849              PL_curcopdb = PL_curcop;
2850          if (CvLVALUE(cv)) {
2851              /* check for lsub that handles lvalue subroutines */
2852              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2853              /* if lsub not found then fall back to DB::sub */
2854              if (!cv) cv = GvCV(PL_DBsub);
2855          } else {
2856              cv = GvCV(PL_DBsub);
2857          }
2858
2859         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2860             DIE(aTHX_ "No DB::sub routine defined");
2861     }
2862
2863     if (!(CvISXSUB(cv))) {
2864         /* This path taken at least 75% of the time   */
2865         dMARK;
2866         register I32 items = SP - MARK;
2867         AV* const padlist = CvPADLIST(cv);
2868         PUSHBLOCK(cx, CXt_SUB, MARK);
2869         PUSHSUB(cx);
2870         cx->blk_sub.retop = PL_op->op_next;
2871         CvDEPTH(cv)++;
2872         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2873          * that eval'' ops within this sub know the correct lexical space.
2874          * Owing the speed considerations, we choose instead to search for
2875          * the cv using find_runcv() when calling doeval().
2876          */
2877         if (CvDEPTH(cv) >= 2) {
2878             PERL_STACK_OVERFLOW_CHECK();
2879             pad_push(padlist, CvDEPTH(cv));
2880         }
2881         SAVECOMPPAD();
2882         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2883         if (hasargs) {
2884             AV *const av = MUTABLE_AV(PAD_SVl(0));
2885             if (AvREAL(av)) {
2886                 /* @_ is normally not REAL--this should only ever
2887                  * happen when DB::sub() calls things that modify @_ */
2888                 av_clear(av);
2889                 AvREAL_off(av);
2890                 AvREIFY_on(av);
2891             }
2892             cx->blk_sub.savearray = GvAV(PL_defgv);
2893             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2894             CX_CURPAD_SAVE(cx->blk_sub);
2895             cx->blk_sub.argarray = av;
2896             ++MARK;
2897
2898             if (items > AvMAX(av) + 1) {
2899                 SV **ary = AvALLOC(av);
2900                 if (AvARRAY(av) != ary) {
2901                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2902                     AvARRAY(av) = ary;
2903                 }
2904                 if (items > AvMAX(av) + 1) {
2905                     AvMAX(av) = items - 1;
2906                     Renew(ary,items,SV*);
2907                     AvALLOC(av) = ary;
2908                     AvARRAY(av) = ary;
2909                 }
2910             }
2911             Copy(MARK,AvARRAY(av),items,SV*);
2912             AvFILLp(av) = items - 1;
2913
2914             while (items--) {
2915                 if (*MARK)
2916                     SvTEMP_off(*MARK);
2917                 MARK++;
2918             }
2919         }
2920         /* warning must come *after* we fully set up the context
2921          * stuff so that __WARN__ handlers can safely dounwind()
2922          * if they want to
2923          */
2924         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2925             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2926             sub_crush_depth(cv);
2927         RETURNOP(CvSTART(cv));
2928     }
2929     else {
2930         I32 markix = TOPMARK;
2931
2932         PUTBACK;
2933
2934         if (!hasargs) {
2935             /* Need to copy @_ to stack. Alternative may be to
2936              * switch stack to @_, and copy return values
2937              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2938             AV * const av = GvAV(PL_defgv);
2939             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2940
2941             if (items) {
2942                 /* Mark is at the end of the stack. */
2943                 EXTEND(SP, items);
2944                 Copy(AvARRAY(av), SP + 1, items, SV*);
2945                 SP += items;
2946                 PUTBACK ;
2947             }
2948         }
2949         /* We assume first XSUB in &DB::sub is the called one. */
2950         if (PL_curcopdb) {
2951             SAVEVPTR(PL_curcop);
2952             PL_curcop = PL_curcopdb;
2953             PL_curcopdb = NULL;
2954         }
2955         /* Do we need to open block here? XXXX */
2956
2957         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2958         assert(CvXSUB(cv));
2959         CvXSUB(cv)(aTHX_ cv);
2960
2961         /* Enforce some sanity in scalar context. */
2962         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2963             if (markix > PL_stack_sp - PL_stack_base)
2964                 *(PL_stack_base + markix) = &PL_sv_undef;
2965             else
2966                 *(PL_stack_base + markix) = *PL_stack_sp;
2967             PL_stack_sp = PL_stack_base + markix;
2968         }
2969         LEAVE;
2970         return NORMAL;
2971     }
2972 }
2973
2974 void
2975 Perl_sub_crush_depth(pTHX_ CV *cv)
2976 {
2977     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2978
2979     if (CvANON(cv))
2980         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2981     else {
2982         SV* const tmpstr = sv_newmortal();
2983         gv_efullname3(tmpstr, CvGV(cv), NULL);
2984         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2985                     SVfARG(tmpstr));
2986     }
2987 }
2988
2989 PP(pp_aelem)
2990 {
2991     dVAR; dSP;
2992     SV** svp;
2993     SV* const elemsv = POPs;
2994     IV elem = SvIV(elemsv);
2995     AV *const av = MUTABLE_AV(POPs);
2996     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2997     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2998     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2999     bool preeminent = TRUE;
3000     SV *sv;
3001
3002     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
3003         Perl_warner(aTHX_ packWARN(WARN_MISC),
3004                     "Use of reference \"%"SVf"\" as array index",
3005                     SVfARG(elemsv));
3006     if (elem > 0)
3007         elem -= CopARYBASE_get(PL_curcop);
3008     if (SvTYPE(av) != SVt_PVAV)
3009         RETPUSHUNDEF;
3010
3011     if (localizing) {
3012         MAGIC *mg;
3013         HV *stash;
3014
3015         /* If we can determine whether the element exist,
3016          * Try to preserve the existenceness of a tied array
3017          * element by using EXISTS and DELETE if possible.
3018          * Fallback to FETCH and STORE otherwise. */
3019         if (SvCANEXISTDELETE(av))
3020             preeminent = av_exists(av, elem);
3021     }
3022
3023     svp = av_fetch(av, elem, lval && !defer);
3024     if (lval) {
3025 #ifdef PERL_MALLOC_WRAP
3026          if (SvUOK(elemsv)) {
3027               const UV uv = SvUV(elemsv);
3028               elem = uv > IV_MAX ? IV_MAX : uv;
3029          }
3030          else if (SvNOK(elemsv))
3031               elem = (IV)SvNV(elemsv);
3032          if (elem > 0) {
3033               static const char oom_array_extend[] =
3034                 "Out of memory during array extend"; /* Duplicated in av.c */
3035               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3036          }
3037 #endif
3038         if (!svp || *svp == &PL_sv_undef) {
3039             SV* lv;
3040             if (!defer)
3041                 DIE(aTHX_ PL_no_aelem, elem);
3042             lv = sv_newmortal();
3043             sv_upgrade(lv, SVt_PVLV);
3044             LvTYPE(lv) = 'y';
3045             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3046             LvTARG(lv) = SvREFCNT_inc_simple(av);
3047             LvTARGOFF(lv) = elem;
3048             LvTARGLEN(lv) = 1;
3049             PUSHs(lv);
3050             RETURN;
3051         }
3052         if (localizing) {
3053             if (preeminent)
3054                 save_aelem(av, elem, svp);
3055             else
3056                 SAVEADELETE(av, elem);
3057         }
3058         else if (PL_op->op_private & OPpDEREF)
3059             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3060     }
3061     sv = (svp ? *svp : &PL_sv_undef);
3062     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3063         mg_get(sv);
3064     PUSHs(sv);
3065     RETURN;
3066 }
3067
3068 void
3069 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3070 {
3071     PERL_ARGS_ASSERT_VIVIFY_REF;
3072
3073     SvGETMAGIC(sv);
3074     if (!SvOK(sv)) {
3075         if (SvREADONLY(sv))
3076             Perl_croak_no_modify(aTHX);
3077         prepare_SV_for_RV(sv);
3078         switch (to_what) {
3079         case OPpDEREF_SV:
3080             SvRV_set(sv, newSV(0));
3081             break;
3082         case OPpDEREF_AV:
3083             SvRV_set(sv, MUTABLE_SV(newAV()));
3084             break;
3085         case OPpDEREF_HV:
3086             SvRV_set(sv, MUTABLE_SV(newHV()));
3087             break;
3088         }
3089         SvROK_on(sv);
3090         SvSETMAGIC(sv);
3091     }
3092 }
3093
3094 PP(pp_method)
3095 {
3096     dVAR; dSP;
3097     SV* const sv = TOPs;
3098
3099     if (SvROK(sv)) {
3100         SV* const rsv = SvRV(sv);
3101         if (SvTYPE(rsv) == SVt_PVCV) {
3102             SETs(rsv);
3103             RETURN;
3104         }
3105     }
3106
3107     SETs(method_common(sv, NULL));
3108     RETURN;
3109 }
3110
3111 PP(pp_method_named)
3112 {
3113     dVAR; dSP;
3114     SV* const sv = cSVOP_sv;
3115     U32 hash = SvSHARED_HASH(sv);
3116
3117     XPUSHs(method_common(sv, &hash));
3118     RETURN;
3119 }
3120
3121 STATIC SV *
3122 S_method_common(pTHX_ SV* meth, U32* hashp)
3123 {
3124     dVAR;
3125     SV* ob;
3126     GV* gv;
3127     HV* stash;
3128     const char* packname = NULL;
3129     SV *packsv = NULL;
3130     STRLEN packlen;
3131     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3132
3133     PERL_ARGS_ASSERT_METHOD_COMMON;
3134
3135     if (!sv)
3136         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3137                    SVfARG(meth));
3138
3139     SvGETMAGIC(sv);
3140     if (SvROK(sv))
3141         ob = MUTABLE_SV(SvRV(sv));
3142     else {
3143         GV* iogv;
3144
3145         /* this isn't a reference */
3146         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3147           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3148           if (he) {
3149             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3150             goto fetch;
3151           }
3152         }
3153
3154         if (!SvOK(sv) ||
3155             !(packname) ||
3156             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3157             !(ob=MUTABLE_SV(GvIO(iogv))))
3158         {
3159             /* this isn't the name of a filehandle either */
3160             if (!packname ||
3161                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3162                     ? !isIDFIRST_utf8((U8*)packname)
3163                     : !isIDFIRST(*packname)
3164                 ))
3165             {
3166                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3167                            SVfARG(meth),
3168                            SvOK(sv) ? "without a package or object reference"
3169                                     : "on an undefined value");
3170             }
3171             /* assume it's a package name */
3172             stash = gv_stashpvn(packname, packlen, 0);
3173             if (!stash)
3174                 packsv = sv;
3175             else {
3176                 SV* const ref = newSViv(PTR2IV(stash));
3177                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3178             }
3179             goto fetch;
3180         }
3181         /* it _is_ a filehandle name -- replace with a reference */
3182         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3183     }
3184
3185     /* if we got here, ob should be a reference or a glob */
3186     if (!ob || !(SvOBJECT(ob)
3187                  || (SvTYPE(ob) == SVt_PVGV
3188                      && isGV_with_GP(ob)
3189                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3190                      && SvOBJECT(ob))))
3191     {
3192         const char * const name = SvPV_nolen_const(meth);
3193         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3194                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3195                    name);
3196     }
3197
3198     stash = SvSTASH(ob);
3199
3200   fetch:
3201     /* NOTE: stash may be null, hope hv_fetch_ent and
3202        gv_fetchmethod can cope (it seems they can) */
3203
3204     /* shortcut for simple names */
3205     if (hashp) {
3206         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3207         if (he) {
3208             gv = MUTABLE_GV(HeVAL(he));
3209             if (isGV(gv) && GvCV(gv) &&
3210                 (!GvCVGEN(gv) || GvCVGEN(gv)
3211                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3212                 return MUTABLE_SV(GvCV(gv));
3213         }
3214     }
3215
3216     gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3217                               SvPV_nolen_const(meth),
3218                               GV_AUTOLOAD | GV_CROAK);
3219
3220     assert(gv);
3221
3222     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3223 }
3224
3225 /*
3226  * Local variables:
3227  * c-indentation-style: bsd
3228  * c-basic-offset: 4
3229  * indent-tabs-mode: t
3230  * End:
3231  *
3232  * ex: set ts=8 sts=4 sw=4 noet:
3233  */