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