pp_hot.c

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