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