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