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) { /* not $l .= $r */
 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 { /* $l .= $r */
 258         if (!SvOK(TARG)) {
 259             if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
 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             /* $r.$r: 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_stashsv(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             /* try short-buffering it. Please update t/op/readline.t
1644              * if you change the growth length.
1645              */
1646             Sv_Grow(sv, 80);
1647         }
1648         offset = 0;
1649         if (type == OP_RCATLINE && SvOK(sv)) {
1650             if (!SvPOK(sv)) {
1651                 SvPV_force_nolen(sv);
1652             }
1653             offset = SvCUR(sv);
1654         }
1655     }
1656     else {
1657         sv = sv_2mortal(newSV(80));
1658         offset = 0;
1659     }
1660
1661     /* This should not be marked tainted if the fp is marked clean */
1662 #define MAYBE_TAINT_LINE(io, sv) \
1663     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1664         TAINT;                          \
1665         SvTAINTED_on(sv);               \
1666     }
1667
1668 /* delay EOF state for a snarfed empty file */
1669 #define SNARF_EOF(gimme,rs,io,sv) \
1670     (gimme != G_SCALAR || SvCUR(sv)                                     \
1671      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1672
1673     for (;;) {
1674         PUTBACK;
1675         if (!sv_gets(sv, fp, offset)
1676             && (type == OP_GLOB
1677                 || SNARF_EOF(gimme, PL_rs, io, sv)
1678                 || PerlIO_error(fp)))
1679         {
1680             PerlIO_clearerr(fp);
1681             if (IoFLAGS(io) & IOf_ARGV) {
1682                 fp = nextargv(PL_last_in_gv);
1683                 if (fp)
1684                     continue;
1685                 (void)do_close(PL_last_in_gv, FALSE);
1686             }
1687             else if (type == OP_GLOB) {
1688                 if (!do_close(PL_last_in_gv, FALSE)) {
1689                     Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
1690                                    "glob failed (child exited with status %d%s)",
1691                                    (int)(STATUS_CURRENT >> 8),
1692                                    (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1693                 }
1694             }
1695             if (gimme == G_SCALAR) {
1696                 if (type != OP_RCATLINE) {
1697                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1698                     SvOK_off(TARG);
1699                 }
1700                 SPAGAIN;
1701                 PUSHTARG;
1702             }
1703             MAYBE_TAINT_LINE(io, sv);
1704             RETURN;
1705         }
1706         MAYBE_TAINT_LINE(io, sv);
1707         IoLINES(io)++;
1708         IoFLAGS(io) |= IOf_NOLINE;
1709         SvSETMAGIC(sv);
1710         SPAGAIN;
1711         XPUSHs(sv);
1712         if (type == OP_GLOB) {
1713             const char *t1;
1714
1715             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1716                 char * const tmps = SvEND(sv) - 1;
1717                 if (*tmps == *SvPVX_const(PL_rs)) {
1718                     *tmps = '\0';
1719                     SvCUR_set(sv, SvCUR(sv) - 1);
1720                 }
1721             }
1722             for (t1 = SvPVX_const(sv); *t1; t1++)
1723                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1724                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1725                         break;
1726             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1727                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1728                 continue;
1729             }
1730         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1731              if (ckWARN(WARN_UTF8)) {
1732                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1733                 const STRLEN len = SvCUR(sv) - offset;
1734                 const U8 *f;
1735
1736                 if (!is_utf8_string_loc(s, len, &f))
1737                     /* Emulate :encoding(utf8) warning in the same case. */
1738                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1739                                 "utf8 \"\\x%02X\" does not map to Unicode",
1740                                 f < (U8*)SvEND(sv) ? *f : 0);
1741              }
1742         }
1743         if (gimme == G_ARRAY) {
1744             if (SvLEN(sv) - SvCUR(sv) > 20) {
1745                 SvPV_shrink_to_cur(sv);
1746             }
1747             sv = sv_2mortal(newSV(80));
1748             continue;
1749         }
1750         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1751             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1752             const STRLEN new_len
1753                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1754             SvPV_renew(sv, new_len);
1755         }
1756         RETURN;
1757     }
1758 }
1759
1760 PP(pp_enter)
1761 {
1762     dVAR; dSP;
1763     register PERL_CONTEXT *cx;
1764     I32 gimme = OP_GIMME(PL_op, -1);
1765
1766     if (gimme == -1) {
1767         if (cxstack_ix >= 0) {
1768             /* If this flag is set, we're just inside a return, so we should
1769              * store the caller's context */
1770             gimme = (PL_op->op_flags & OPf_SPECIAL)
1771                 ? block_gimme()
1772                 : cxstack[cxstack_ix].blk_gimme;
1773         } else
1774             gimme = G_SCALAR;
1775     }
1776
1777     ENTER_with_name("block");
1778
1779     SAVETMPS;
1780     PUSHBLOCK(cx, CXt_BLOCK, SP);
1781
1782     RETURN;
1783 }
1784
1785 PP(pp_helem)
1786 {
1787     dVAR; dSP;
1788     HE* he;
1789     SV **svp;
1790     SV * const keysv = POPs;
1791     HV * const hv = MUTABLE_HV(POPs);
1792     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1793     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1794     SV *sv;
1795     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1796     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
1797     bool preeminent = TRUE;
1798
1799     if (SvTYPE(hv) != SVt_PVHV)
1800         RETPUSHUNDEF;
1801
1802     if (localizing) {
1803         MAGIC *mg;
1804         HV *stash;
1805
1806         /* If we can determine whether the element exist,
1807          * Try to preserve the existenceness of a tied hash
1808          * element by using EXISTS and DELETE if possible.
1809          * Fallback to FETCH and STORE otherwise. */
1810         if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
1811             preeminent = hv_exists_ent(hv, keysv, 0);
1812     }
1813
1814     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1815     svp = he ? &HeVAL(he) : NULL;
1816     if (lval) {
1817         if (!svp || *svp == &PL_sv_undef) {
1818             SV* lv;
1819             SV* key2;
1820             if (!defer) {
1821                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1822             }
1823             lv = sv_newmortal();
1824             sv_upgrade(lv, SVt_PVLV);
1825             LvTYPE(lv) = 'y';
1826             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1827             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1828             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1829             LvTARGLEN(lv) = 1;
1830             PUSHs(lv);
1831             RETURN;
1832         }
1833         if (localizing) {
1834             if (HvNAME_get(hv) && isGV(*svp))
1835                 save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
1836             else if (preeminent)
1837                 save_helem_flags(hv, keysv, svp,
1838                      (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
1839             else
1840                 SAVEHDELETE(hv, keysv);
1841         }
1842         else if (PL_op->op_private & OPpDEREF)
1843             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1844     }
1845     sv = (svp ? *svp : &PL_sv_undef);
1846     /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
1847      * was to make C<local $tied{foo} = $tied{foo}> possible.
1848      * However, it seems no longer to be needed for that purpose, and
1849      * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
1850      * would loop endlessly since the pos magic is getting set on the
1851      * mortal copy and lost. However, the copy has the effect of
1852      * triggering the get magic, and losing it altogether made things like
1853      * c<$tied{foo};> in void context no longer do get magic, which some
1854      * code relied on. Also, delayed triggering of magic on @+ and friends
1855      * meant the original regex may be out of scope by now. So as a
1856      * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
1857      * being called too many times). */
1858     if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
1859         mg_get(sv);
1860     PUSHs(sv);
1861     RETURN;
1862 }
1863
1864 PP(pp_leave)
1865 {
1866     dVAR; dSP;
1867     register PERL_CONTEXT *cx;
1868     SV **newsp;
1869     PMOP *newpm;
1870     I32 gimme;
1871
1872     if (PL_op->op_flags & OPf_SPECIAL) {
1873         cx = &cxstack[cxstack_ix];
1874         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1875     }
1876
1877     POPBLOCK(cx,newpm);
1878
1879     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
1880
1881     TAINT_NOT;
1882     if (gimme == G_VOID)
1883         SP = newsp;
1884     else if (gimme == G_SCALAR) {
1885         register SV **mark;
1886         MARK = newsp + 1;
1887         if (MARK <= SP) {
1888             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1889                 *MARK = TOPs;
1890             else
1891                 *MARK = sv_mortalcopy(TOPs);
1892         } else {
1893             MEXTEND(mark,0);
1894             *MARK = &PL_sv_undef;
1895         }
1896         SP = MARK;
1897     }
1898     else if (gimme == G_ARRAY) {
1899         /* in case LEAVE wipes old return values */
1900         register SV **mark;
1901         for (mark = newsp + 1; mark <= SP; mark++) {
1902             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1903                 *mark = sv_mortalcopy(*mark);
1904                 TAINT_NOT;      /* Each item is independent */
1905             }
1906         }
1907     }
1908     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1909
1910     LEAVE_with_name("block");
1911
1912     RETURN;
1913 }
1914
1915 PP(pp_iter)
1916 {
1917     dVAR; dSP;
1918     register PERL_CONTEXT *cx;
1919     SV *sv, *oldsv;
1920     SV **itersvp;
1921     AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1922     bool av_is_stack = FALSE;
1923
1924     EXTEND(SP, 1);
1925     cx = &cxstack[cxstack_ix];
1926     if (!CxTYPE_is_LOOP(cx))
1927         DIE(aTHX_ "panic: pp_iter");
1928
1929     itersvp = CxITERVAR(cx);
1930     if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1931             /* string increment */
1932             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1933             SV *end = cx->blk_loop.state_u.lazysv.end;
1934             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1935                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1936             STRLEN maxlen = 0;
1937             const char *max = SvPV_const(end, maxlen);
1938             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1939                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1940                     /* safe to reuse old SV */
1941                     sv_setsv(*itersvp, cur);
1942                 }
1943                 else
1944                 {
1945                     /* we need a fresh SV every time so that loop body sees a
1946                      * completely new SV for closures/references to work as
1947                      * they used to */
1948                     oldsv = *itersvp;
1949                     *itersvp = newSVsv(cur);
1950                     SvREFCNT_dec(oldsv);
1951                 }
1952                 if (strEQ(SvPVX_const(cur), max))
1953                     sv_setiv(cur, 0); /* terminate next time */
1954                 else
1955                     sv_inc(cur);
1956                 RETPUSHYES;
1957             }
1958             RETPUSHNO;
1959     }
1960     else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1961         /* integer increment */
1962         if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1963             RETPUSHNO;
1964
1965         /* don't risk potential race */
1966         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1967             /* safe to reuse old SV */
1968             sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1969         }
1970         else
1971         {
1972             /* we need a fresh SV every time so that loop body sees a
1973              * completely new SV for closures/references to work as they
1974              * used to */
1975             oldsv = *itersvp;
1976             *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1977             SvREFCNT_dec(oldsv);
1978         }
1979
1980         /* Handle end of range at IV_MAX */
1981         if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1982             (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1983         {
1984             cx->blk_loop.state_u.lazyiv.cur++;
1985             cx->blk_loop.state_u.lazyiv.end++;
1986         }
1987
1988         RETPUSHYES;
1989     }
1990
1991     /* iterate array */
1992     assert(CxTYPE(cx) == CXt_LOOP_FOR);
1993     av = cx->blk_loop.state_u.ary.ary;
1994     if (!av) {
1995         av_is_stack = TRUE;
1996         av = PL_curstack;
1997     }
1998     if (PL_op->op_private & OPpITER_REVERSED) {
1999         if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
2000                                     ? cx->blk_loop.resetsp + 1 : 0))
2001             RETPUSHNO;
2002
2003         if (SvMAGICAL(av) || AvREIFY(av)) {
2004             SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
2005             sv = svp ? *svp : NULL;
2006         }
2007         else {
2008             sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
2009         }
2010     }
2011     else {
2012         if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
2013                                     AvFILL(av)))
2014             RETPUSHNO;
2015
2016         if (SvMAGICAL(av) || AvREIFY(av)) {
2017             SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
2018             sv = svp ? *svp : NULL;
2019         }
2020         else {
2021             sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
2022         }
2023     }
2024
2025     if (sv && SvIS_FREED(sv)) {
2026         *itersvp = NULL;
2027         Perl_croak(aTHX_ "Use of freed value in iteration");
2028     }
2029
2030     if (sv) {
2031         SvTEMP_off(sv);
2032         SvREFCNT_inc_simple_void_NN(sv);
2033     }
2034     else
2035         sv = &PL_sv_undef;
2036     if (!av_is_stack && sv == &PL_sv_undef) {
2037         SV *lv = newSV_type(SVt_PVLV);
2038         LvTYPE(lv) = 'y';
2039         sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2040         LvTARG(lv) = SvREFCNT_inc_simple(av);
2041         LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2042         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2043         sv = lv;
2044     }
2045
2046     oldsv = *itersvp;
2047     *itersvp = sv;
2048     SvREFCNT_dec(oldsv);
2049
2050     RETPUSHYES;
2051 }
2052
2053 PP(pp_subst)
2054 {
2055     dVAR; dSP; dTARG;
2056     register PMOP *pm = cPMOP;
2057     PMOP *rpm = pm;
2058     register char *s;
2059     char *strend;
2060     register char *m;
2061     const char *c;
2062     register char *d;
2063     STRLEN clen;
2064     I32 iters = 0;
2065     I32 maxiters;
2066     register I32 i;
2067     bool once;
2068     U8 rxtainted;
2069     char *orig;
2070     U8 r_flags;
2071     register REGEXP *rx = PM_GETRE(pm);
2072     STRLEN len;
2073     int force_on_match = 0;
2074     const I32 oldsave = PL_savestack_ix;
2075     STRLEN slen;
2076     bool doutf8 = FALSE;
2077     I32 matched;
2078 #ifdef PERL_OLD_COPY_ON_WRITE
2079     bool is_cow;
2080 #endif
2081     SV *nsv = NULL;
2082     /* known replacement string? */
2083     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2084
2085     PERL_ASYNC_CHECK();
2086
2087     if (PL_op->op_flags & OPf_STACKED)
2088         TARG = POPs;
2089     else if (PL_op->op_private & OPpTARGET_MY)
2090         GETTARGET;
2091     else {
2092         TARG = DEFSV;
2093         EXTEND(SP,1);
2094     }
2095
2096     /* In non-destructive replacement mode, duplicate target scalar so it
2097      * remains unchanged. */
2098     if (rpm->op_pmflags & PMf_NONDESTRUCT)
2099         TARG = newSVsv(TARG);
2100
2101 #ifdef PERL_OLD_COPY_ON_WRITE
2102     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2103        because they make integers such as 256 "false".  */
2104     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2105 #else
2106     if (SvIsCOW(TARG))
2107         sv_force_normal_flags(TARG,0);
2108 #endif
2109     if (
2110 #ifdef PERL_OLD_COPY_ON_WRITE
2111         !is_cow &&
2112 #endif
2113         (SvREADONLY(TARG)
2114          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2115                || SvTYPE(TARG) > SVt_PVLV)
2116              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2117         Perl_croak_no_modify(aTHX);
2118     PUTBACK;
2119
2120   setup_match:
2121     s = SvPV_mutable(TARG, len);
2122     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2123         force_on_match = 1;
2124     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2125                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2126     if (PL_tainted)
2127         rxtainted |= 2;
2128     TAINT_NOT;
2129
2130     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2131
2132   force_it:
2133     if (!pm || !s)
2134         DIE(aTHX_ "panic: pp_subst");
2135
2136     strend = s + len;
2137     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2138     maxiters = 2 * slen + 10;   /* We can match twice at each
2139                                    position, once with zero-length,
2140                                    second time with non-zero. */
2141
2142     if (!RX_PRELEN(rx) && PL_curpm) {
2143         pm = PL_curpm;
2144         rx = PM_GETRE(pm);
2145     }
2146     r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2147             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2148                ? REXEC_COPY_STR : 0;
2149     if (SvSCREAM(TARG))
2150         r_flags |= REXEC_SCREAM;
2151
2152     orig = m = s;
2153     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2154         PL_bostr = orig;
2155         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2156
2157         if (!s)
2158             goto nope;
2159         /* How to do it in subst? */
2160 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2161              && !PL_sawampersand
2162              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2163              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2164                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2165                       && (r_flags & REXEC_SCREAM))))
2166             goto yup;
2167 */
2168     }
2169
2170     /* only replace once? */
2171     once = !(rpm->op_pmflags & PMf_GLOBAL);
2172     matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2173                          r_flags | REXEC_CHECKED);
2174     /* known replacement string? */
2175     if (dstr) {
2176
2177         /* Upgrade the source if the replacement is utf8 but the source is not,
2178          * but only if it matched; see
2179          * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2180          */
2181         if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2182             const STRLEN new_len = sv_utf8_upgrade(TARG);
2183
2184             /* If the lengths are the same, the pattern contains only
2185              * invariants, can keep going; otherwise, various internal markers
2186              * could be off, so redo */
2187             if (new_len != len) {
2188                 goto setup_match;
2189             }
2190         }
2191
2192         /* replacement needing upgrading? */
2193         if (DO_UTF8(TARG) && !doutf8) {
2194              nsv = sv_newmortal();
2195              SvSetSV(nsv, dstr);
2196              if (PL_encoding)
2197                   sv_recode_to_utf8(nsv, PL_encoding);
2198              else
2199                   sv_utf8_upgrade(nsv);
2200              c = SvPV_const(nsv, clen);
2201              doutf8 = TRUE;
2202         }
2203         else {
2204             c = SvPV_const(dstr, clen);
2205             doutf8 = DO_UTF8(dstr);
2206         }
2207     }
2208     else {
2209         c = NULL;
2210         doutf8 = FALSE;
2211     }
2212
2213     /* can do inplace substitution? */
2214     if (c
2215 #ifdef PERL_OLD_COPY_ON_WRITE
2216         && !is_cow
2217 #endif
2218         && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2219         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2220         && (!doutf8 || SvUTF8(TARG))) {
2221         if (!matched)
2222         {
2223             SPAGAIN;
2224             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2225                 PUSHs(TARG);
2226             else
2227                 PUSHs(&PL_sv_no);
2228             LEAVE_SCOPE(oldsave);
2229             RETURN;
2230         }
2231 #ifdef PERL_OLD_COPY_ON_WRITE
2232         if (SvIsCOW(TARG)) {
2233             assert (!force_on_match);
2234             goto have_a_cow;
2235         }
2236 #endif
2237         if (force_on_match) {
2238             force_on_match = 0;
2239             s = SvPV_force(TARG, len);
2240             goto force_it;
2241         }
2242         d = s;
2243         PL_curpm = pm;
2244         SvSCREAM_off(TARG);     /* disable possible screamer */
2245         if (once) {
2246             rxtainted |= RX_MATCH_TAINTED(rx);
2247             m = orig + RX_OFFS(rx)[0].start;
2248             d = orig + RX_OFFS(rx)[0].end;
2249             s = orig;
2250             if (m - s > strend - d) {  /* faster to shorten from end */
2251                 if (clen) {
2252                     Copy(c, m, clen, char);
2253                     m += clen;
2254                 }
2255                 i = strend - d;
2256                 if (i > 0) {
2257                     Move(d, m, i, char);
2258                     m += i;
2259                 }
2260                 *m = '\0';
2261                 SvCUR_set(TARG, m - s);
2262             }
2263             else if ((i = m - s)) {     /* faster from front */
2264                 d -= clen;
2265                 m = d;
2266                 Move(s, d - i, i, char);
2267                 sv_chop(TARG, d-i);
2268                 if (clen)
2269                     Copy(c, m, clen, char);
2270             }
2271             else if (clen) {
2272                 d -= clen;
2273                 sv_chop(TARG, d);
2274                 Copy(c, d, clen, char);
2275             }
2276             else {
2277                 sv_chop(TARG, d);
2278             }
2279             TAINT_IF(rxtainted & 1);
2280             SPAGAIN;
2281             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2282                 PUSHs(TARG);
2283             else
2284                 PUSHs(&PL_sv_yes);
2285         }
2286         else {
2287             do {
2288                 if (iters++ > maxiters)
2289                     DIE(aTHX_ "Substitution loop");
2290                 rxtainted |= RX_MATCH_TAINTED(rx);
2291                 m = RX_OFFS(rx)[0].start + orig;
2292                 if ((i = m - s)) {
2293                     if (s != d)
2294                         Move(s, d, i, char);
2295                     d += i;
2296                 }
2297                 if (clen) {
2298                     Copy(c, d, clen, char);
2299                     d += clen;
2300                 }
2301                 s = RX_OFFS(rx)[0].end + orig;
2302             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2303                                  TARG, NULL,
2304                                  /* don't match same null twice */
2305                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2306             if (s != d) {
2307                 i = strend - s;
2308                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2309                 Move(s, d, i+1, char);          /* include the NUL */
2310             }
2311             TAINT_IF(rxtainted & 1);
2312             SPAGAIN;
2313             if (rpm->op_pmflags & PMf_NONDESTRUCT)
2314                 PUSHs(TARG);
2315             else
2316                 mPUSHi((I32)iters);
2317         }
2318         (void)SvPOK_only_UTF8(TARG);
2319         TAINT_IF(rxtainted);
2320         if (SvSMAGICAL(TARG)) {
2321             PUTBACK;
2322             mg_set(TARG);
2323             SPAGAIN;
2324         }
2325         SvTAINT(TARG);
2326         if (doutf8)
2327             SvUTF8_on(TARG);
2328         LEAVE_SCOPE(oldsave);
2329         RETURN;
2330     }
2331
2332     if (matched)
2333     {
2334         if (force_on_match) {
2335             force_on_match = 0;
2336             s = SvPV_force(TARG, len);
2337             goto force_it;
2338         }
2339 #ifdef PERL_OLD_COPY_ON_WRITE
2340       have_a_cow:
2341 #endif
2342         rxtainted |= RX_MATCH_TAINTED(rx);
2343         dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2344         SAVEFREESV(dstr);
2345         PL_curpm = pm;
2346         if (!c) {
2347             register PERL_CONTEXT *cx;
2348             SPAGAIN;
2349             PUSHSUBST(cx);
2350             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2351         }
2352         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2353         do {
2354             if (iters++ > maxiters)
2355                 DIE(aTHX_ "Substitution loop");
2356             rxtainted |= RX_MATCH_TAINTED(rx);
2357             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2358                 m = s;
2359                 s = orig;
2360                 orig = RX_SUBBEG(rx);
2361                 s = orig + (m - s);
2362                 strend = s + (strend - m);
2363             }
2364             m = RX_OFFS(rx)[0].start + orig;
2365             if (doutf8 && !SvUTF8(dstr))
2366                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2367             else
2368                 sv_catpvn(dstr, s, m-s);
2369             s = RX_OFFS(rx)[0].end + orig;
2370             if (clen)
2371                 sv_catpvn(dstr, c, clen);
2372             if (once)
2373                 break;
2374         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2375                              TARG, NULL, r_flags));
2376         if (doutf8 && !DO_UTF8(TARG))
2377             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2378         else
2379             sv_catpvn(dstr, s, strend - s);
2380
2381 #ifdef PERL_OLD_COPY_ON_WRITE
2382         /* The match may make the string COW. If so, brilliant, because that's
2383            just saved us one malloc, copy and free - the regexp has donated
2384            the old buffer, and we malloc an entirely new one, rather than the
2385            regexp malloc()ing a buffer and copying our original, only for
2386            us to throw it away here during the substitution.  */
2387         if (SvIsCOW(TARG)) {
2388             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2389         } else
2390 #endif
2391         {
2392             SvPV_free(TARG);
2393         }
2394         SvPV_set(TARG, SvPVX(dstr));
2395         SvCUR_set(TARG, SvCUR(dstr));
2396         SvLEN_set(TARG, SvLEN(dstr));
2397         doutf8 |= DO_UTF8(dstr);
2398         SvPV_set(dstr, NULL);
2399
2400         TAINT_IF(rxtainted & 1);
2401         SPAGAIN;
2402         if (rpm->op_pmflags & PMf_NONDESTRUCT)
2403             PUSHs(TARG);
2404         else
2405             mPUSHi((I32)iters);
2406
2407         (void)SvPOK_only(TARG);
2408         if (doutf8)
2409             SvUTF8_on(TARG);
2410         TAINT_IF(rxtainted);
2411         SvSETMAGIC(TARG);
2412         SvTAINT(TARG);
2413         LEAVE_SCOPE(oldsave);
2414         RETURN;
2415     }
2416     goto ret_no;
2417
2418 nope:
2419 ret_no:
2420     SPAGAIN;
2421     if (rpm->op_pmflags & PMf_NONDESTRUCT)
2422         PUSHs(TARG);
2423     else
2424         PUSHs(&PL_sv_no);
2425     LEAVE_SCOPE(oldsave);
2426     RETURN;
2427 }
2428
2429 PP(pp_grepwhile)
2430 {
2431     dVAR; dSP;
2432
2433     if (SvTRUEx(POPs))
2434         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2435     ++*PL_markstack_ptr;
2436     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2437
2438     /* All done yet? */
2439     if (PL_stack_base + *PL_markstack_ptr > SP) {
2440         I32 items;
2441         const I32 gimme = GIMME_V;
2442
2443         LEAVE_with_name("grep");                                        /* exit outer scope */
2444         (void)POPMARK;                          /* pop src */
2445         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2446         (void)POPMARK;                          /* pop dst */
2447         SP = PL_stack_base + POPMARK;           /* pop original mark */
2448         if (gimme == G_SCALAR) {
2449             if (PL_op->op_private & OPpGREP_LEX) {
2450                 SV* const sv = sv_newmortal();
2451                 sv_setiv(sv, items);
2452                 PUSHs(sv);
2453             }
2454             else {
2455                 dTARGET;
2456                 XPUSHi(items);
2457             }
2458         }
2459         else if (gimme == G_ARRAY)
2460             SP += items;
2461         RETURN;
2462     }
2463     else {
2464         SV *src;
2465
2466         ENTER_with_name("grep_item");                                   /* enter inner scope */
2467         SAVEVPTR(PL_curpm);
2468
2469         src = PL_stack_base[*PL_markstack_ptr];
2470         SvTEMP_off(src);
2471         if (PL_op->op_private & OPpGREP_LEX)
2472             PAD_SVl(PL_op->op_targ) = src;
2473         else
2474             DEFSV_set(src);
2475
2476         RETURNOP(cLOGOP->op_other);
2477     }
2478 }
2479
2480 PP(pp_leavesub)
2481 {
2482     dVAR; dSP;
2483     SV **mark;
2484     SV **newsp;
2485     PMOP *newpm;
2486     I32 gimme;
2487     register PERL_CONTEXT *cx;
2488     SV *sv;
2489
2490     if (CxMULTICALL(&cxstack[cxstack_ix]))
2491         return 0;
2492
2493     POPBLOCK(cx,newpm);
2494     cxstack_ix++; /* temporarily protect top context */
2495
2496     TAINT_NOT;
2497     if (gimme == G_SCALAR) {
2498         MARK = newsp + 1;
2499         if (MARK <= SP) {
2500             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2501                 if (SvTEMP(TOPs)) {
2502                     *MARK = SvREFCNT_inc(TOPs);
2503                     FREETMPS;
2504                     sv_2mortal(*MARK);
2505                 }
2506                 else {
2507                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2508                     FREETMPS;
2509                     *MARK = sv_mortalcopy(sv);
2510                     SvREFCNT_dec(sv);
2511                 }
2512             }
2513             else
2514                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2515         }
2516         else {
2517             MEXTEND(MARK, 0);
2518             *MARK = &PL_sv_undef;
2519         }
2520         SP = MARK;
2521     }
2522     else if (gimme == G_ARRAY) {
2523         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2524             if (!SvTEMP(*MARK)) {
2525                 *MARK = sv_mortalcopy(*MARK);
2526                 TAINT_NOT;      /* Each item is independent */
2527             }
2528         }
2529     }
2530     PUTBACK;
2531
2532     LEAVE;
2533     cxstack_ix--;
2534     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2535     PL_curpm = newpm;   /* ... and pop $1 et al */
2536
2537     LEAVESUB(sv);
2538     return cx->blk_sub.retop;
2539 }
2540
2541 /* This duplicates the above code because the above code must not
2542  * get any slower by more conditions */
2543 PP(pp_leavesublv)
2544 {
2545     dVAR; dSP;
2546     SV **mark;
2547     SV **newsp;
2548     PMOP *newpm;
2549     I32 gimme;
2550     register PERL_CONTEXT *cx;
2551     SV *sv;
2552
2553     if (CxMULTICALL(&cxstack[cxstack_ix]))
2554         return 0;
2555
2556     POPBLOCK(cx,newpm);
2557     cxstack_ix++; /* temporarily protect top context */
2558
2559     TAINT_NOT;
2560
2561     if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2562         /* We are an argument to a function or grep().
2563          * This kind of lvalueness was legal before lvalue
2564          * subroutines too, so be backward compatible:
2565          * cannot report errors.  */
2566
2567         /* Scalar context *is* possible, on the LHS of -> only,
2568          * as in f()->meth().  But this is not an lvalue. */
2569         if (gimme == G_SCALAR)
2570             goto temporise;
2571         if (gimme == G_ARRAY) {
2572             if (!CvLVALUE(cx->blk_sub.cv))
2573                 goto temporise_array;
2574             EXTEND_MORTAL(SP - newsp);
2575             for (mark = newsp + 1; mark <= SP; mark++) {
2576                 if (SvTEMP(*mark))
2577                     NOOP;
2578                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2579                     *mark = sv_mortalcopy(*mark);
2580                 else {
2581                     /* Can be a localized value subject to deletion. */
2582                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2583                     SvREFCNT_inc_void(*mark);
2584                 }
2585             }
2586         }
2587     }
2588     else if (CxLVAL(cx)) {     /* Leave it as it is if we can. */
2589         /* Here we go for robustness, not for speed, so we change all
2590          * the refcounts so the caller gets a live guy. Cannot set
2591          * TEMP, so sv_2mortal is out of question. */
2592         if (!CvLVALUE(cx->blk_sub.cv)) {
2593             LEAVE;
2594             cxstack_ix--;
2595             POPSUB(cx,sv);
2596             PL_curpm = newpm;
2597             LEAVESUB(sv);
2598             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2599         }
2600         if (gimme == G_SCALAR) {
2601             MARK = newsp + 1;
2602             EXTEND_MORTAL(1);
2603             if (MARK == SP) {
2604                 /* Temporaries are bad unless they happen to be elements
2605                  * of a tied hash or array */
2606                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2607                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2608                     LEAVE;
2609                     cxstack_ix--;
2610                     POPSUB(cx,sv);
2611                     PL_curpm = newpm;
2612                     LEAVESUB(sv);
2613                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2614                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2615                         : "a readonly value" : "a temporary");
2616                 }
2617                 else {                  /* Can be a localized value
2618                                          * subject to deletion. */
2619                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2620                     SvREFCNT_inc_void(*mark);
2621                 }
2622             }
2623             else {                      /* Should not happen? */
2624                 LEAVE;
2625                 cxstack_ix--;
2626                 POPSUB(cx,sv);
2627                 PL_curpm = newpm;
2628                 LEAVESUB(sv);
2629                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2630                     (MARK > SP ? "Empty array" : "Array"));
2631             }
2632             SP = MARK;
2633         }
2634         else if (gimme == G_ARRAY) {
2635             EXTEND_MORTAL(SP - newsp);
2636             for (mark = newsp + 1; mark <= SP; mark++) {
2637                 if (*mark != &PL_sv_undef
2638                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2639                     /* Might be flattened array after $#array =  */
2640                     PUTBACK;
2641                     LEAVE;
2642                     cxstack_ix--;
2643                     POPSUB(cx,sv);
2644                     PL_curpm = newpm;
2645                     LEAVESUB(sv);
2646                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2647                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2648                 }
2649                 else {
2650                     /* Can be a localized value subject to deletion. */
2651                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2652                     SvREFCNT_inc_void(*mark);
2653                 }
2654             }
2655         }
2656     }
2657     else {
2658         if (gimme == G_SCALAR) {
2659           temporise:
2660             MARK = newsp + 1;
2661             if (MARK <= SP) {
2662                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2663                     if (SvTEMP(TOPs)) {
2664                         *MARK = SvREFCNT_inc(TOPs);
2665                         FREETMPS;
2666                         sv_2mortal(*MARK);
2667                     }
2668                     else {
2669                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2670                         FREETMPS;
2671                         *MARK = sv_mortalcopy(sv);
2672                         SvREFCNT_dec(sv);
2673                     }
2674                 }
2675                 else
2676                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2677             }
2678             else {
2679                 MEXTEND(MARK, 0);
2680                 *MARK = &PL_sv_undef;
2681             }
2682             SP = MARK;
2683         }
2684         else if (gimme == G_ARRAY) {
2685           temporise_array:
2686             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2687                 if (!SvTEMP(*MARK)) {
2688                     *MARK = sv_mortalcopy(*MARK);
2689                     TAINT_NOT;  /* Each item is independent */
2690                 }
2691             }
2692         }
2693     }
2694     PUTBACK;
2695
2696     LEAVE;
2697     cxstack_ix--;
2698     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2699     PL_curpm = newpm;   /* ... and pop $1 et al */
2700
2701     LEAVESUB(sv);
2702     return cx->blk_sub.retop;
2703 }
2704
2705 PP(pp_entersub)
2706 {
2707     dVAR; dSP; dPOPss;
2708     GV *gv;
2709     register CV *cv;
2710     register PERL_CONTEXT *cx;
2711     I32 gimme;
2712     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2713
2714     if (!sv)
2715         DIE(aTHX_ "Not a CODE reference");
2716     switch (SvTYPE(sv)) {
2717         /* This is overwhelming the most common case:  */
2718     case SVt_PVGV:
2719         if (!isGV_with_GP(sv))
2720             DIE(aTHX_ "Not a CODE reference");
2721         if (!(cv = GvCVu((const GV *)sv))) {
2722             HV *stash;
2723             cv = sv_2cv(sv, &stash, &gv, 0);
2724         }
2725         if (!cv) {
2726             ENTER;
2727             SAVETMPS;
2728             goto try_autoload;
2729         }
2730         break;
2731     default:
2732         if (sv == &PL_sv_yes) {         /* unfound import, ignore */
2733             if (hasargs)
2734                 SP = PL_stack_base + POPMARK;
2735             RETURN;
2736         }
2737         SvGETMAGIC(sv);
2738         if (SvROK(sv)) {
2739             SV * const * sp = &sv;      /* Used in tryAMAGICunDEREF macro. */
2740             tryAMAGICunDEREF(to_cv);
2741         }
2742         else {
2743             const char *sym;
2744             STRLEN len;
2745             sym = SvPV_nomg_const(sv, len);
2746             if (!sym)
2747                 DIE(aTHX_ PL_no_usym, "a subroutine");
2748             if (PL_op->op_private & HINT_STRICT_REFS)
2749                 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2750             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2751             break;
2752         }
2753         cv = MUTABLE_CV(SvRV(sv));
2754         if (SvTYPE(cv) == SVt_PVCV)
2755             break;
2756         /* FALL THROUGH */
2757     case SVt_PVHV:
2758     case SVt_PVAV:
2759         DIE(aTHX_ "Not a CODE reference");
2760         /* This is the second most common case:  */
2761     case SVt_PVCV:
2762         cv = MUTABLE_CV(sv);
2763         break;
2764     }
2765
2766     ENTER;
2767     SAVETMPS;
2768
2769   retry:
2770     if (!CvROOT(cv) && !CvXSUB(cv)) {
2771         GV* autogv;
2772         SV* sub_name;
2773
2774         /* anonymous or undef'd function leaves us no recourse */
2775         if (CvANON(cv) || !(gv = CvGV(cv)))
2776             DIE(aTHX_ "Undefined subroutine called");
2777
2778         /* autoloaded stub? */
2779         if (cv != GvCV(gv)) {
2780             cv = GvCV(gv);
2781         }
2782         /* should call AUTOLOAD now? */
2783         else {
2784 try_autoload:
2785             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2786                                    FALSE)))
2787             {
2788                 cv = GvCV(autogv);
2789             }
2790             /* sorry */
2791             else {
2792                 sub_name = sv_newmortal();
2793                 gv_efullname3(sub_name, gv, NULL);
2794                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2795             }
2796         }
2797         if (!cv)
2798             DIE(aTHX_ "Not a CODE reference");
2799         goto retry;
2800     }
2801
2802     gimme = GIMME_V;
2803     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2804          Perl_get_db_sub(aTHX_ &sv, cv);
2805          if (CvISXSUB(cv))
2806              PL_curcopdb = PL_curcop;
2807          if (CvLVALUE(cv)) {
2808              /* check for lsub that handles lvalue subroutines */
2809              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2810              /* if lsub not found then fall back to DB::sub */
2811              if (!cv) cv = GvCV(PL_DBsub);
2812          } else {
2813              cv = GvCV(PL_DBsub);
2814          }
2815
2816         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2817             DIE(aTHX_ "No DB::sub routine defined");
2818     }
2819
2820     if (!(CvISXSUB(cv))) {
2821         /* This path taken at least 75% of the time   */
2822         dMARK;
2823         register I32 items = SP - MARK;
2824         AV* const padlist = CvPADLIST(cv);
2825         PUSHBLOCK(cx, CXt_SUB, MARK);
2826         PUSHSUB(cx);
2827         cx->blk_sub.retop = PL_op->op_next;
2828         CvDEPTH(cv)++;
2829         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2830          * that eval'' ops within this sub know the correct lexical space.
2831          * Owing the speed considerations, we choose instead to search for
2832          * the cv using find_runcv() when calling doeval().
2833          */
2834         if (CvDEPTH(cv) >= 2) {
2835             PERL_STACK_OVERFLOW_CHECK();
2836             pad_push(padlist, CvDEPTH(cv));
2837         }
2838         SAVECOMPPAD();
2839         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2840         if (hasargs) {
2841             AV *const av = MUTABLE_AV(PAD_SVl(0));
2842             if (AvREAL(av)) {
2843                 /* @_ is normally not REAL--this should only ever
2844                  * happen when DB::sub() calls things that modify @_ */
2845                 av_clear(av);
2846                 AvREAL_off(av);
2847                 AvREIFY_on(av);
2848             }
2849             cx->blk_sub.savearray = GvAV(PL_defgv);
2850             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2851             CX_CURPAD_SAVE(cx->blk_sub);
2852             cx->blk_sub.argarray = av;
2853             ++MARK;
2854
2855             if (items > AvMAX(av) + 1) {
2856                 SV **ary = AvALLOC(av);
2857                 if (AvARRAY(av) != ary) {
2858                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2859                     AvARRAY(av) = ary;
2860                 }
2861                 if (items > AvMAX(av) + 1) {
2862                     AvMAX(av) = items - 1;
2863                     Renew(ary,items,SV*);
2864                     AvALLOC(av) = ary;
2865                     AvARRAY(av) = ary;
2866                 }
2867             }
2868             Copy(MARK,AvARRAY(av),items,SV*);
2869             AvFILLp(av) = items - 1;
2870
2871             while (items--) {
2872                 if (*MARK)
2873                     SvTEMP_off(*MARK);
2874                 MARK++;
2875             }
2876         }
2877         /* warning must come *after* we fully set up the context
2878          * stuff so that __WARN__ handlers can safely dounwind()
2879          * if they want to
2880          */
2881         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2882             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2883             sub_crush_depth(cv);
2884         RETURNOP(CvSTART(cv));
2885     }
2886     else {
2887         I32 markix = TOPMARK;
2888
2889         PUTBACK;
2890
2891         if (!hasargs) {
2892             /* Need to copy @_ to stack. Alternative may be to
2893              * switch stack to @_, and copy return values
2894              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2895             AV * const av = GvAV(PL_defgv);
2896             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2897
2898             if (items) {
2899                 /* Mark is at the end of the stack. */
2900                 EXTEND(SP, items);
2901                 Copy(AvARRAY(av), SP + 1, items, SV*);
2902                 SP += items;
2903                 PUTBACK ;
2904             }
2905         }
2906         /* We assume first XSUB in &DB::sub is the called one. */
2907         if (PL_curcopdb) {
2908             SAVEVPTR(PL_curcop);
2909             PL_curcop = PL_curcopdb;
2910             PL_curcopdb = NULL;
2911         }
2912         /* Do we need to open block here? XXXX */
2913
2914         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2915         assert(CvXSUB(cv));
2916         CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
2917
2918         /* Enforce some sanity in scalar context. */
2919         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2920             if (markix > PL_stack_sp - PL_stack_base)
2921                 *(PL_stack_base + markix) = &PL_sv_undef;
2922             else
2923                 *(PL_stack_base + markix) = *PL_stack_sp;
2924             PL_stack_sp = PL_stack_base + markix;
2925         }
2926         LEAVE;
2927         return NORMAL;
2928     }
2929 }
2930
2931 void
2932 Perl_sub_crush_depth(pTHX_ CV *cv)
2933 {
2934     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2935
2936     if (CvANON(cv))
2937         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2938     else {
2939         SV* const tmpstr = sv_newmortal();
2940         gv_efullname3(tmpstr, CvGV(cv), NULL);
2941         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2942                     SVfARG(tmpstr));
2943     }
2944 }
2945
2946 PP(pp_aelem)
2947 {
2948     dVAR; dSP;
2949     SV** svp;
2950     SV* const elemsv = POPs;
2951     IV elem = SvIV(elemsv);
2952     AV *const av = MUTABLE_AV(POPs);
2953     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2954     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2955     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2956     bool preeminent = TRUE;
2957     SV *sv;
2958
2959     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2960         Perl_warner(aTHX_ packWARN(WARN_MISC),
2961                     "Use of reference \"%"SVf"\" as array index",
2962                     SVfARG(elemsv));
2963     if (elem > 0)
2964         elem -= CopARYBASE_get(PL_curcop);
2965     if (SvTYPE(av) != SVt_PVAV)
2966         RETPUSHUNDEF;
2967
2968     if (localizing) {
2969         MAGIC *mg;
2970         HV *stash;
2971
2972         /* If we can determine whether the element exist,
2973          * Try to preserve the existenceness of a tied array
2974          * element by using EXISTS and DELETE if possible.
2975          * Fallback to FETCH and STORE otherwise. */
2976         if (SvCANEXISTDELETE(av))
2977             preeminent = av_exists(av, elem);
2978     }
2979
2980     svp = av_fetch(av, elem, lval && !defer);
2981     if (lval) {
2982 #ifdef PERL_MALLOC_WRAP
2983          if (SvUOK(elemsv)) {
2984               const UV uv = SvUV(elemsv);
2985               elem = uv > IV_MAX ? IV_MAX : uv;
2986          }
2987          else if (SvNOK(elemsv))
2988               elem = (IV)SvNV(elemsv);
2989          if (elem > 0) {
2990               static const char oom_array_extend[] =
2991                 "Out of memory during array extend"; /* Duplicated in av.c */
2992               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2993          }
2994 #endif
2995         if (!svp || *svp == &PL_sv_undef) {
2996             SV* lv;
2997             if (!defer)
2998                 DIE(aTHX_ PL_no_aelem, elem);
2999             lv = sv_newmortal();
3000             sv_upgrade(lv, SVt_PVLV);
3001             LvTYPE(lv) = 'y';
3002             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3003             LvTARG(lv) = SvREFCNT_inc_simple(av);
3004             LvTARGOFF(lv) = elem;
3005             LvTARGLEN(lv) = 1;
3006             PUSHs(lv);
3007             RETURN;
3008         }
3009         if (localizing) {
3010             if (preeminent)
3011                 save_aelem(av, elem, svp);
3012             else
3013                 SAVEADELETE(av, elem);
3014         }
3015         else if (PL_op->op_private & OPpDEREF)
3016             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3017     }
3018     sv = (svp ? *svp : &PL_sv_undef);
3019     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3020         mg_get(sv);
3021     PUSHs(sv);
3022     RETURN;
3023 }
3024
3025 void
3026 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3027 {
3028     PERL_ARGS_ASSERT_VIVIFY_REF;
3029
3030     SvGETMAGIC(sv);
3031     if (!SvOK(sv)) {
3032         if (SvREADONLY(sv))
3033             Perl_croak_no_modify(aTHX);
3034         prepare_SV_for_RV(sv);
3035         switch (to_what) {
3036         case OPpDEREF_SV:
3037             SvRV_set(sv, newSV(0));
3038             break;
3039         case OPpDEREF_AV:
3040             SvRV_set(sv, MUTABLE_SV(newAV()));
3041             break;
3042         case OPpDEREF_HV:
3043             SvRV_set(sv, MUTABLE_SV(newHV()));
3044             break;
3045         }
3046         SvROK_on(sv);
3047         SvSETMAGIC(sv);
3048     }
3049 }
3050
3051 PP(pp_method)
3052 {
3053     dVAR; dSP;
3054     SV* const sv = TOPs;
3055
3056     if (SvROK(sv)) {
3057         SV* const rsv = SvRV(sv);
3058         if (SvTYPE(rsv) == SVt_PVCV) {
3059             SETs(rsv);
3060             RETURN;
3061         }
3062     }
3063
3064     SETs(method_common(sv, NULL));
3065     RETURN;
3066 }
3067
3068 PP(pp_method_named)
3069 {
3070     dVAR; dSP;
3071     SV* const sv = cSVOP_sv;
3072     U32 hash = SvSHARED_HASH(sv);
3073
3074     XPUSHs(method_common(sv, &hash));
3075     RETURN;
3076 }
3077
3078 STATIC SV *
3079 S_method_common(pTHX_ SV* meth, U32* hashp)
3080 {
3081     dVAR;
3082     SV* ob;
3083     GV* gv;
3084     HV* stash;
3085     const char* packname = NULL;
3086     SV *packsv = NULL;
3087     STRLEN packlen;
3088     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3089
3090     PERL_ARGS_ASSERT_METHOD_COMMON;
3091
3092     if (!sv)
3093         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3094                    SVfARG(meth));
3095
3096     SvGETMAGIC(sv);
3097     if (SvROK(sv))
3098         ob = MUTABLE_SV(SvRV(sv));
3099     else {
3100         GV* iogv;
3101
3102         /* this isn't a reference */
3103         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3104           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3105           if (he) {
3106             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3107             goto fetch;
3108           }
3109         }
3110
3111         if (!SvOK(sv) ||
3112             !(packname) ||
3113             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3114             !(ob=MUTABLE_SV(GvIO(iogv))))
3115         {
3116             /* this isn't the name of a filehandle either */
3117             if (!packname ||
3118                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3119                     ? !isIDFIRST_utf8((U8*)packname)
3120                     : !isIDFIRST(*packname)
3121                 ))
3122             {
3123                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3124                            SVfARG(meth),
3125                            SvOK(sv) ? "without a package or object reference"
3126                                     : "on an undefined value");
3127             }
3128             /* assume it's a package name */
3129             stash = gv_stashpvn(packname, packlen, 0);
3130             if (!stash)
3131                 packsv = sv;
3132             else {
3133                 SV* const ref = newSViv(PTR2IV(stash));
3134                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3135             }
3136             goto fetch;
3137         }
3138         /* it _is_ a filehandle name -- replace with a reference */
3139         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3140     }
3141
3142     /* if we got here, ob should be a reference or a glob */
3143     if (!ob || !(SvOBJECT(ob)
3144                  || (SvTYPE(ob) == SVt_PVGV
3145                      && isGV_with_GP(ob)
3146                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3147                      && SvOBJECT(ob))))
3148     {
3149         const char * const name = SvPV_nolen_const(meth);
3150         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3151                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3152                    name);
3153     }
3154
3155     stash = SvSTASH(ob);
3156
3157   fetch:
3158     /* NOTE: stash may be null, hope hv_fetch_ent and
3159        gv_fetchmethod can cope (it seems they can) */
3160
3161     /* shortcut for simple names */
3162     if (hashp) {
3163         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3164         if (he) {
3165             gv = MUTABLE_GV(HeVAL(he));
3166             if (isGV(gv) && GvCV(gv) &&
3167                 (!GvCVGEN(gv) || GvCVGEN(gv)
3168                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3169                 return MUTABLE_SV(GvCV(gv));
3170         }
3171     }
3172
3173     gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3174                               SvPV_nolen_const(meth),
3175                               GV_AUTOLOAD | GV_CROAK);
3176
3177     assert(gv);
3178
3179     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3180 }
3181
3182 /*
3183  * Local variables:
3184  * c-indentation-style: bsd
3185  * c-basic-offset: 4
3186  * indent-tabs-mode: t
3187  * End:
3188  *
3189  * ex: set ts=8 sts=4 sw=4 noet:
3190  */