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   setup_match:
2130     s = SvPV_mutable(TARG, len);
2131     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2132         force_on_match = 1;
2133     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2134                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2135     if (PL_tainted)
2136         rxtainted |= 2;
2137     TAINT_NOT;
2138
2139     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2140
2141   force_it:
2142     if (!pm || !s)
2143         DIE(aTHX_ "panic: pp_subst");
2144
2145     strend = s + len;
2146     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2147     maxiters = 2 * slen + 10;   /* We can match twice at each
2148                                    position, once with zero-length,
2149                                    second time with non-zero. */
2150
2151     if (!RX_PRELEN(rx) && PL_curpm) {
2152         pm = PL_curpm;
2153         rx = PM_GETRE(pm);
2154     }
2155     r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2156             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2157                ? REXEC_COPY_STR : 0;
2158     if (SvSCREAM(TARG))
2159         r_flags |= REXEC_SCREAM;
2160
2161     orig = m = s;
2162     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2163         PL_bostr = orig;
2164         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2165
2166         if (!s)
2167             goto nope;
2168         /* How to do it in subst? */
2169 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2170              && !PL_sawampersand
2171              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2172              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2173                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2174                       && (r_flags & REXEC_SCREAM))))
2175             goto yup;
2176 */
2177     }
2178
2179     /* only replace once? */
2180     once = !(rpm->op_pmflags & PMf_GLOBAL);
2181     matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2182                          r_flags | REXEC_CHECKED);
2183     /* known replacement string? */
2184     if (dstr) {
2185
2186         /* Upgrade the source if the replacement is utf8 but the source is not,
2187          * but only if it matched; see
2188          * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
2189          */
2190         if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
2191             const STRLEN new_len = sv_utf8_upgrade(TARG);
2192
2193             /* If the lengths are the same, the pattern contains only
2194              * invariants, can keep going; otherwise, various internal markers
2195              * could be off, so redo */
2196             if (new_len != len) {
2197                 goto setup_match;
2198             }
2199         }
2200
2201         /* replacement needing upgrading? */
2202         if (DO_UTF8(TARG) && !doutf8) {
2203              nsv = sv_newmortal();
2204              SvSetSV(nsv, dstr);
2205              if (PL_encoding)
2206                   sv_recode_to_utf8(nsv, PL_encoding);
2207              else
2208                   sv_utf8_upgrade(nsv);
2209              c = SvPV_const(nsv, clen);
2210              doutf8 = TRUE;
2211         }
2212         else {
2213             c = SvPV_const(dstr, clen);
2214             doutf8 = DO_UTF8(dstr);
2215         }
2216     }
2217     else {
2218         c = NULL;
2219         doutf8 = FALSE;
2220     }
2221
2222     /* can do inplace substitution? */
2223     if (c
2224 #ifdef PERL_OLD_COPY_ON_WRITE
2225         && !is_cow
2226 #endif
2227         && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2228         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2229         && (!doutf8 || SvUTF8(TARG))) {
2230         if (!matched)
2231         {
2232             SPAGAIN;
2233             PUSHs(&PL_sv_no);
2234             LEAVE_SCOPE(oldsave);
2235             RETURN;
2236         }
2237 #ifdef PERL_OLD_COPY_ON_WRITE
2238         if (SvIsCOW(TARG)) {
2239             assert (!force_on_match);
2240             goto have_a_cow;
2241         }
2242 #endif
2243         if (force_on_match) {
2244             force_on_match = 0;
2245             s = SvPV_force(TARG, len);
2246             goto force_it;
2247         }
2248         d = s;
2249         PL_curpm = pm;
2250         SvSCREAM_off(TARG);     /* disable possible screamer */
2251         if (once) {
2252             rxtainted |= RX_MATCH_TAINTED(rx);
2253             m = orig + RX_OFFS(rx)[0].start;
2254             d = orig + RX_OFFS(rx)[0].end;
2255             s = orig;
2256             if (m - s > strend - d) {  /* faster to shorten from end */
2257                 if (clen) {
2258                     Copy(c, m, clen, char);
2259                     m += clen;
2260                 }
2261                 i = strend - d;
2262                 if (i > 0) {
2263                     Move(d, m, i, char);
2264                     m += i;
2265                 }
2266                 *m = '\0';
2267                 SvCUR_set(TARG, m - s);
2268             }
2269             else if ((i = m - s)) {     /* faster from front */
2270                 d -= clen;
2271                 m = d;
2272                 Move(s, d - i, i, char);
2273                 sv_chop(TARG, d-i);
2274                 if (clen)
2275                     Copy(c, m, clen, char);
2276             }
2277             else if (clen) {
2278                 d -= clen;
2279                 sv_chop(TARG, d);
2280                 Copy(c, d, clen, char);
2281             }
2282             else {
2283                 sv_chop(TARG, d);
2284             }
2285             TAINT_IF(rxtainted & 1);
2286             SPAGAIN;
2287             PUSHs(&PL_sv_yes);
2288         }
2289         else {
2290             do {
2291                 if (iters++ > maxiters)
2292                     DIE(aTHX_ "Substitution loop");
2293                 rxtainted |= RX_MATCH_TAINTED(rx);
2294                 m = RX_OFFS(rx)[0].start + orig;
2295                 if ((i = m - s)) {
2296                     if (s != d)
2297                         Move(s, d, i, char);
2298                     d += i;
2299                 }
2300                 if (clen) {
2301                     Copy(c, d, clen, char);
2302                     d += clen;
2303                 }
2304                 s = RX_OFFS(rx)[0].end + orig;
2305             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2306                                  TARG, NULL,
2307                                  /* don't match same null twice */
2308                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2309             if (s != d) {
2310                 i = strend - s;
2311                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2312                 Move(s, d, i+1, char);          /* include the NUL */
2313             }
2314             TAINT_IF(rxtainted & 1);
2315             SPAGAIN;
2316             mPUSHi((I32)iters);
2317         }
2318         (void)SvPOK_only_UTF8(TARG);
2319         TAINT_IF(rxtainted);
2320         if (SvSMAGICAL(TARG)) {
2321             PUTBACK;
2322             mg_set(TARG);
2323             SPAGAIN;
2324         }
2325         SvTAINT(TARG);
2326         if (doutf8)
2327             SvUTF8_on(TARG);
2328         LEAVE_SCOPE(oldsave);
2329         RETURN;
2330     }
2331
2332     if (matched)
2333     {
2334         if (force_on_match) {
2335             force_on_match = 0;
2336             s = SvPV_force(TARG, len);
2337             goto force_it;
2338         }
2339 #ifdef PERL_OLD_COPY_ON_WRITE
2340       have_a_cow:
2341 #endif
2342         rxtainted |= RX_MATCH_TAINTED(rx);
2343         dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2344         SAVEFREESV(dstr);
2345         PL_curpm = pm;
2346         if (!c) {
2347             register PERL_CONTEXT *cx;
2348             SPAGAIN;
2349             PUSHSUBST(cx);
2350             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2351         }
2352         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2353         do {
2354             if (iters++ > maxiters)
2355                 DIE(aTHX_ "Substitution loop");
2356             rxtainted |= RX_MATCH_TAINTED(rx);
2357             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2358                 m = s;
2359                 s = orig;
2360                 orig = RX_SUBBEG(rx);
2361                 s = orig + (m - s);
2362                 strend = s + (strend - m);
2363             }
2364             m = RX_OFFS(rx)[0].start + orig;
2365             if (doutf8 && !SvUTF8(dstr))
2366                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2367             else
2368                 sv_catpvn(dstr, s, m-s);
2369             s = RX_OFFS(rx)[0].end + orig;
2370             if (clen)
2371                 sv_catpvn(dstr, c, clen);
2372             if (once)
2373                 break;
2374         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2375                              TARG, NULL, r_flags));
2376         if (doutf8 && !DO_UTF8(TARG))
2377             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2378         else
2379             sv_catpvn(dstr, s, strend - s);
2380
2381 #ifdef PERL_OLD_COPY_ON_WRITE
2382         /* The match may make the string COW. If so, brilliant, because that's
2383            just saved us one malloc, copy and free - the regexp has donated
2384            the old buffer, and we malloc an entirely new one, rather than the
2385            regexp malloc()ing a buffer and copying our original, only for
2386            us to throw it away here during the substitution.  */
2387         if (SvIsCOW(TARG)) {
2388             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2389         } else
2390 #endif
2391         {
2392             SvPV_free(TARG);
2393         }
2394         SvPV_set(TARG, SvPVX(dstr));
2395         SvCUR_set(TARG, SvCUR(dstr));
2396         SvLEN_set(TARG, SvLEN(dstr));
2397         doutf8 |= DO_UTF8(dstr);
2398         SvPV_set(dstr, NULL);
2399
2400         TAINT_IF(rxtainted & 1);
2401         SPAGAIN;
2402         mPUSHi((I32)iters);
2403
2404         (void)SvPOK_only(TARG);
2405         if (doutf8)
2406             SvUTF8_on(TARG);
2407         TAINT_IF(rxtainted);
2408         SvSETMAGIC(TARG);
2409         SvTAINT(TARG);
2410         LEAVE_SCOPE(oldsave);
2411         RETURN;
2412     }
2413     goto ret_no;
2414
2415 nope:
2416 ret_no:
2417     SPAGAIN;
2418     PUSHs(&PL_sv_no);
2419     LEAVE_SCOPE(oldsave);
2420     RETURN;
2421 }
2422
2423 PP(pp_grepwhile)
2424 {
2425     dVAR; dSP;
2426
2427     if (SvTRUEx(POPs))
2428         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2429     ++*PL_markstack_ptr;
2430     LEAVE_with_name("grep_item");                                       /* exit inner scope */
2431
2432     /* All done yet? */
2433     if (PL_stack_base + *PL_markstack_ptr > SP) {
2434         I32 items;
2435         const I32 gimme = GIMME_V;
2436
2437         LEAVE_with_name("grep");                                        /* exit outer scope */
2438         (void)POPMARK;                          /* pop src */
2439         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2440         (void)POPMARK;                          /* pop dst */
2441         SP = PL_stack_base + POPMARK;           /* pop original mark */
2442         if (gimme == G_SCALAR) {
2443             if (PL_op->op_private & OPpGREP_LEX) {
2444                 SV* const sv = sv_newmortal();
2445                 sv_setiv(sv, items);
2446                 PUSHs(sv);
2447             }
2448             else {
2449                 dTARGET;
2450                 XPUSHi(items);
2451             }
2452         }
2453         else if (gimme == G_ARRAY)
2454             SP += items;
2455         RETURN;
2456     }
2457     else {
2458         SV *src;
2459
2460         ENTER_with_name("grep_item");                                   /* enter inner scope */
2461         SAVEVPTR(PL_curpm);
2462
2463         src = PL_stack_base[*PL_markstack_ptr];
2464         SvTEMP_off(src);
2465         if (PL_op->op_private & OPpGREP_LEX)
2466             PAD_SVl(PL_op->op_targ) = src;
2467         else
2468             DEFSV_set(src);
2469
2470         RETURNOP(cLOGOP->op_other);
2471     }
2472 }
2473
2474 PP(pp_leavesub)
2475 {
2476     dVAR; dSP;
2477     SV **mark;
2478     SV **newsp;
2479     PMOP *newpm;
2480     I32 gimme;
2481     register PERL_CONTEXT *cx;
2482     SV *sv;
2483
2484     if (CxMULTICALL(&cxstack[cxstack_ix]))
2485         return 0;
2486
2487     POPBLOCK(cx,newpm);
2488     cxstack_ix++; /* temporarily protect top context */
2489
2490     TAINT_NOT;
2491     if (gimme == G_SCALAR) {
2492         MARK = newsp + 1;
2493         if (MARK <= SP) {
2494             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2495                 if (SvTEMP(TOPs)) {
2496                     *MARK = SvREFCNT_inc(TOPs);
2497                     FREETMPS;
2498                     sv_2mortal(*MARK);
2499                 }
2500                 else {
2501                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2502                     FREETMPS;
2503                     *MARK = sv_mortalcopy(sv);
2504                     SvREFCNT_dec(sv);
2505                 }
2506             }
2507             else
2508                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2509         }
2510         else {
2511             MEXTEND(MARK, 0);
2512             *MARK = &PL_sv_undef;
2513         }
2514         SP = MARK;
2515     }
2516     else if (gimme == G_ARRAY) {
2517         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2518             if (!SvTEMP(*MARK)) {
2519                 *MARK = sv_mortalcopy(*MARK);
2520                 TAINT_NOT;      /* Each item is independent */
2521             }
2522         }
2523     }
2524     PUTBACK;
2525
2526     LEAVE;
2527     cxstack_ix--;
2528     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2529     PL_curpm = newpm;   /* ... and pop $1 et al */
2530
2531     LEAVESUB(sv);
2532     return cx->blk_sub.retop;
2533 }
2534
2535 /* This duplicates the above code because the above code must not
2536  * get any slower by more conditions */
2537 PP(pp_leavesublv)
2538 {
2539     dVAR; dSP;
2540     SV **mark;
2541     SV **newsp;
2542     PMOP *newpm;
2543     I32 gimme;
2544     register PERL_CONTEXT *cx;
2545     SV *sv;
2546
2547     if (CxMULTICALL(&cxstack[cxstack_ix]))
2548         return 0;
2549
2550     POPBLOCK(cx,newpm);
2551     cxstack_ix++; /* temporarily protect top context */
2552
2553     TAINT_NOT;
2554
2555     if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2556         /* We are an argument to a function or grep().
2557          * This kind of lvalueness was legal before lvalue
2558          * subroutines too, so be backward compatible:
2559          * cannot report errors.  */
2560
2561         /* Scalar context *is* possible, on the LHS of -> only,
2562          * as in f()->meth().  But this is not an lvalue. */
2563         if (gimme == G_SCALAR)
2564             goto temporise;
2565         if (gimme == G_ARRAY) {
2566             if (!CvLVALUE(cx->blk_sub.cv))
2567                 goto temporise_array;
2568             EXTEND_MORTAL(SP - newsp);
2569             for (mark = newsp + 1; mark <= SP; mark++) {
2570                 if (SvTEMP(*mark))
2571                     NOOP;
2572                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2573                     *mark = sv_mortalcopy(*mark);
2574                 else {
2575                     /* Can be a localized value subject to deletion. */
2576                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2577                     SvREFCNT_inc_void(*mark);
2578                 }
2579             }
2580         }
2581     }
2582     else if (CxLVAL(cx)) {     /* Leave it as it is if we can. */
2583         /* Here we go for robustness, not for speed, so we change all
2584          * the refcounts so the caller gets a live guy. Cannot set
2585          * TEMP, so sv_2mortal is out of question. */
2586         if (!CvLVALUE(cx->blk_sub.cv)) {
2587             LEAVE;
2588             cxstack_ix--;
2589             POPSUB(cx,sv);
2590             PL_curpm = newpm;
2591             LEAVESUB(sv);
2592             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2593         }
2594         if (gimme == G_SCALAR) {
2595             MARK = newsp + 1;
2596             EXTEND_MORTAL(1);
2597             if (MARK == SP) {
2598                 /* Temporaries are bad unless they happen to be elements
2599                  * of a tied hash or array */
2600                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2601                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2602                     LEAVE;
2603                     cxstack_ix--;
2604                     POPSUB(cx,sv);
2605                     PL_curpm = newpm;
2606                     LEAVESUB(sv);
2607                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2608                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2609                         : "a readonly value" : "a temporary");
2610                 }
2611                 else {                  /* Can be a localized value
2612                                          * subject to deletion. */
2613                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2614                     SvREFCNT_inc_void(*mark);
2615                 }
2616             }
2617             else {                      /* Should not happen? */
2618                 LEAVE;
2619                 cxstack_ix--;
2620                 POPSUB(cx,sv);
2621                 PL_curpm = newpm;
2622                 LEAVESUB(sv);
2623                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2624                     (MARK > SP ? "Empty array" : "Array"));
2625             }
2626             SP = MARK;
2627         }
2628         else if (gimme == G_ARRAY) {
2629             EXTEND_MORTAL(SP - newsp);
2630             for (mark = newsp + 1; mark <= SP; mark++) {
2631                 if (*mark != &PL_sv_undef
2632                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2633                     /* Might be flattened array after $#array =  */
2634                     PUTBACK;
2635                     LEAVE;
2636                     cxstack_ix--;
2637                     POPSUB(cx,sv);
2638                     PL_curpm = newpm;
2639                     LEAVESUB(sv);
2640                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2641                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2642                 }
2643                 else {
2644                     /* Can be a localized value subject to deletion. */
2645                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2646                     SvREFCNT_inc_void(*mark);
2647                 }
2648             }
2649         }
2650     }
2651     else {
2652         if (gimme == G_SCALAR) {
2653           temporise:
2654             MARK = newsp + 1;
2655             if (MARK <= SP) {
2656                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2657                     if (SvTEMP(TOPs)) {
2658                         *MARK = SvREFCNT_inc(TOPs);
2659                         FREETMPS;
2660                         sv_2mortal(*MARK);
2661                     }
2662                     else {
2663                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2664                         FREETMPS;
2665                         *MARK = sv_mortalcopy(sv);
2666                         SvREFCNT_dec(sv);
2667                     }
2668                 }
2669                 else
2670                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2671             }
2672             else {
2673                 MEXTEND(MARK, 0);
2674                 *MARK = &PL_sv_undef;
2675             }
2676             SP = MARK;
2677         }
2678         else if (gimme == G_ARRAY) {
2679           temporise_array:
2680             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2681                 if (!SvTEMP(*MARK)) {
2682                     *MARK = sv_mortalcopy(*MARK);
2683                     TAINT_NOT;  /* Each item is independent */
2684                 }
2685             }
2686         }
2687     }
2688     PUTBACK;
2689
2690     LEAVE;
2691     cxstack_ix--;
2692     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2693     PL_curpm = newpm;   /* ... and pop $1 et al */
2694
2695     LEAVESUB(sv);
2696     return cx->blk_sub.retop;
2697 }
2698
2699 PP(pp_entersub)
2700 {
2701     dVAR; dSP; dPOPss;
2702     GV *gv;
2703     register CV *cv;
2704     register PERL_CONTEXT *cx;
2705     I32 gimme;
2706     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2707
2708     if (!sv)
2709         DIE(aTHX_ "Not a CODE reference");
2710     switch (SvTYPE(sv)) {
2711         /* This is overwhelming the most common case:  */
2712     case SVt_PVGV:
2713         if (!isGV_with_GP(sv))
2714             DIE(aTHX_ "Not a CODE reference");
2715         if (!(cv = GvCVu((const GV *)sv))) {
2716             HV *stash;
2717             cv = sv_2cv(sv, &stash, &gv, 0);
2718         }
2719         if (!cv) {
2720             ENTER;
2721             SAVETMPS;
2722             goto try_autoload;
2723         }
2724         break;
2725     default:
2726         if (!SvROK(sv)) {
2727             const char *sym;
2728             STRLEN len;
2729             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2730                 if (hasargs)
2731                     SP = PL_stack_base + POPMARK;
2732                 RETURN;
2733             }
2734             if (SvGMAGICAL(sv)) {
2735                 mg_get(sv);
2736                 if (SvROK(sv))
2737                     goto got_rv;
2738                 if (SvPOKp(sv)) {
2739                     sym = SvPVX_const(sv);
2740                     len = SvCUR(sv);
2741                 } else {
2742                     sym = NULL;
2743                     len = 0;
2744                 }
2745             }
2746             else {
2747                 sym = SvPV_const(sv, len);
2748             }
2749             if (!sym)
2750                 DIE(aTHX_ PL_no_usym, "a subroutine");
2751             if (PL_op->op_private & HINT_STRICT_REFS)
2752                 DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
2753             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2754             break;
2755         }
2756   got_rv:
2757         {
2758             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2759             tryAMAGICunDEREF(to_cv);
2760         }
2761         cv = MUTABLE_CV(SvRV(sv));
2762         if (SvTYPE(cv) == SVt_PVCV)
2763             break;
2764         /* FALL THROUGH */
2765     case SVt_PVHV:
2766     case SVt_PVAV:
2767         DIE(aTHX_ "Not a CODE reference");
2768         /* This is the second most common case:  */
2769     case SVt_PVCV:
2770         cv = MUTABLE_CV(sv);
2771         break;
2772     }
2773
2774     ENTER;
2775     SAVETMPS;
2776
2777   retry:
2778     if (!CvROOT(cv) && !CvXSUB(cv)) {
2779         GV* autogv;
2780         SV* sub_name;
2781
2782         /* anonymous or undef'd function leaves us no recourse */
2783         if (CvANON(cv) || !(gv = CvGV(cv)))
2784             DIE(aTHX_ "Undefined subroutine called");
2785
2786         /* autoloaded stub? */
2787         if (cv != GvCV(gv)) {
2788             cv = GvCV(gv);
2789         }
2790         /* should call AUTOLOAD now? */
2791         else {
2792 try_autoload:
2793             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2794                                    FALSE)))
2795             {
2796                 cv = GvCV(autogv);
2797             }
2798             /* sorry */
2799             else {
2800                 sub_name = sv_newmortal();
2801                 gv_efullname3(sub_name, gv, NULL);
2802                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2803             }
2804         }
2805         if (!cv)
2806             DIE(aTHX_ "Not a CODE reference");
2807         goto retry;
2808     }
2809
2810     gimme = GIMME_V;
2811     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2812          Perl_get_db_sub(aTHX_ &sv, cv);
2813          if (CvISXSUB(cv))
2814              PL_curcopdb = PL_curcop;
2815          if (CvLVALUE(cv)) {
2816              /* check for lsub that handles lvalue subroutines */
2817              cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
2818              /* if lsub not found then fall back to DB::sub */
2819              if (!cv) cv = GvCV(PL_DBsub);
2820          } else {
2821              cv = GvCV(PL_DBsub);
2822          }
2823
2824         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2825             DIE(aTHX_ "No DB::sub routine defined");
2826     }
2827
2828     if (!(CvISXSUB(cv))) {
2829         /* This path taken at least 75% of the time   */
2830         dMARK;
2831         register I32 items = SP - MARK;
2832         AV* const padlist = CvPADLIST(cv);
2833         PUSHBLOCK(cx, CXt_SUB, MARK);
2834         PUSHSUB(cx);
2835         cx->blk_sub.retop = PL_op->op_next;
2836         CvDEPTH(cv)++;
2837         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2838          * that eval'' ops within this sub know the correct lexical space.
2839          * Owing the speed considerations, we choose instead to search for
2840          * the cv using find_runcv() when calling doeval().
2841          */
2842         if (CvDEPTH(cv) >= 2) {
2843             PERL_STACK_OVERFLOW_CHECK();
2844             pad_push(padlist, CvDEPTH(cv));
2845         }
2846         SAVECOMPPAD();
2847         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2848         if (hasargs) {
2849             AV *const av = MUTABLE_AV(PAD_SVl(0));
2850             if (AvREAL(av)) {
2851                 /* @_ is normally not REAL--this should only ever
2852                  * happen when DB::sub() calls things that modify @_ */
2853                 av_clear(av);
2854                 AvREAL_off(av);
2855                 AvREIFY_on(av);
2856             }
2857             cx->blk_sub.savearray = GvAV(PL_defgv);
2858             GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2859             CX_CURPAD_SAVE(cx->blk_sub);
2860             cx->blk_sub.argarray = av;
2861             ++MARK;
2862
2863             if (items > AvMAX(av) + 1) {
2864                 SV **ary = AvALLOC(av);
2865                 if (AvARRAY(av) != ary) {
2866                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2867                     AvARRAY(av) = ary;
2868                 }
2869                 if (items > AvMAX(av) + 1) {
2870                     AvMAX(av) = items - 1;
2871                     Renew(ary,items,SV*);
2872                     AvALLOC(av) = ary;
2873                     AvARRAY(av) = ary;
2874                 }
2875             }
2876             Copy(MARK,AvARRAY(av),items,SV*);
2877             AvFILLp(av) = items - 1;
2878
2879             while (items--) {
2880                 if (*MARK)
2881                     SvTEMP_off(*MARK);
2882                 MARK++;
2883             }
2884         }
2885         /* warning must come *after* we fully set up the context
2886          * stuff so that __WARN__ handlers can safely dounwind()
2887          * if they want to
2888          */
2889         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2890             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2891             sub_crush_depth(cv);
2892         RETURNOP(CvSTART(cv));
2893     }
2894     else {
2895         I32 markix = TOPMARK;
2896
2897         PUTBACK;
2898
2899         if (!hasargs) {
2900             /* Need to copy @_ to stack. Alternative may be to
2901              * switch stack to @_, and copy return values
2902              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2903             AV * const av = GvAV(PL_defgv);
2904             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2905
2906             if (items) {
2907                 /* Mark is at the end of the stack. */
2908                 EXTEND(SP, items);
2909                 Copy(AvARRAY(av), SP + 1, items, SV*);
2910                 SP += items;
2911                 PUTBACK ;
2912             }
2913         }
2914         /* We assume first XSUB in &DB::sub is the called one. */
2915         if (PL_curcopdb) {
2916             SAVEVPTR(PL_curcop);
2917             PL_curcop = PL_curcopdb;
2918             PL_curcopdb = NULL;
2919         }
2920         /* Do we need to open block here? XXXX */
2921
2922         /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
2923         assert(CvXSUB(cv));
2924         CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
2925
2926         /* Enforce some sanity in scalar context. */
2927         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2928             if (markix > PL_stack_sp - PL_stack_base)
2929                 *(PL_stack_base + markix) = &PL_sv_undef;
2930             else
2931                 *(PL_stack_base + markix) = *PL_stack_sp;
2932             PL_stack_sp = PL_stack_base + markix;
2933         }
2934         LEAVE;
2935         return NORMAL;
2936     }
2937 }
2938
2939 void
2940 Perl_sub_crush_depth(pTHX_ CV *cv)
2941 {
2942     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2943
2944     if (CvANON(cv))
2945         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2946     else {
2947         SV* const tmpstr = sv_newmortal();
2948         gv_efullname3(tmpstr, CvGV(cv), NULL);
2949         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2950                     SVfARG(tmpstr));
2951     }
2952 }
2953
2954 PP(pp_aelem)
2955 {
2956     dVAR; dSP;
2957     SV** svp;
2958     SV* const elemsv = POPs;
2959     IV elem = SvIV(elemsv);
2960     AV *const av = MUTABLE_AV(POPs);
2961     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2962     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2963     const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
2964     bool preeminent = TRUE;
2965     SV *sv;
2966
2967     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2968         Perl_warner(aTHX_ packWARN(WARN_MISC),
2969                     "Use of reference \"%"SVf"\" as array index",
2970                     SVfARG(elemsv));
2971     if (elem > 0)
2972         elem -= CopARYBASE_get(PL_curcop);
2973     if (SvTYPE(av) != SVt_PVAV)
2974         RETPUSHUNDEF;
2975
2976     if (localizing) {
2977         MAGIC *mg;
2978         HV *stash;
2979
2980         /* If we can determine whether the element exist,
2981          * Try to preserve the existenceness of a tied array
2982          * element by using EXISTS and DELETE if possible.
2983          * Fallback to FETCH and STORE otherwise. */
2984         if (SvCANEXISTDELETE(av))
2985             preeminent = av_exists(av, elem);
2986     }
2987
2988     svp = av_fetch(av, elem, lval && !defer);
2989     if (lval) {
2990 #ifdef PERL_MALLOC_WRAP
2991          if (SvUOK(elemsv)) {
2992               const UV uv = SvUV(elemsv);
2993               elem = uv > IV_MAX ? IV_MAX : uv;
2994          }
2995          else if (SvNOK(elemsv))
2996               elem = (IV)SvNV(elemsv);
2997          if (elem > 0) {
2998               static const char oom_array_extend[] =
2999                 "Out of memory during array extend"; /* Duplicated in av.c */
3000               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
3001          }
3002 #endif
3003         if (!svp || *svp == &PL_sv_undef) {
3004             SV* lv;
3005             if (!defer)
3006                 DIE(aTHX_ PL_no_aelem, elem);
3007             lv = sv_newmortal();
3008             sv_upgrade(lv, SVt_PVLV);
3009             LvTYPE(lv) = 'y';
3010             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
3011             LvTARG(lv) = SvREFCNT_inc_simple(av);
3012             LvTARGOFF(lv) = elem;
3013             LvTARGLEN(lv) = 1;
3014             PUSHs(lv);
3015             RETURN;
3016         }
3017         if (localizing) {
3018             if (preeminent)
3019                 save_aelem(av, elem, svp);
3020             else
3021                 SAVEADELETE(av, elem);
3022         }
3023         else if (PL_op->op_private & OPpDEREF)
3024             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
3025     }
3026     sv = (svp ? *svp : &PL_sv_undef);
3027     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
3028         mg_get(sv);
3029     PUSHs(sv);
3030     RETURN;
3031 }
3032
3033 void
3034 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
3035 {
3036     PERL_ARGS_ASSERT_VIVIFY_REF;
3037
3038     SvGETMAGIC(sv);
3039     if (!SvOK(sv)) {
3040         if (SvREADONLY(sv))
3041             Perl_croak(aTHX_ "%s", PL_no_modify);
3042         prepare_SV_for_RV(sv);
3043         switch (to_what) {
3044         case OPpDEREF_SV:
3045             SvRV_set(sv, newSV(0));
3046             break;
3047         case OPpDEREF_AV:
3048             SvRV_set(sv, MUTABLE_SV(newAV()));
3049             break;
3050         case OPpDEREF_HV:
3051             SvRV_set(sv, MUTABLE_SV(newHV()));
3052             break;
3053         }
3054         SvROK_on(sv);
3055         SvSETMAGIC(sv);
3056     }
3057 }
3058
3059 PP(pp_method)
3060 {
3061     dVAR; dSP;
3062     SV* const sv = TOPs;
3063
3064     if (SvROK(sv)) {
3065         SV* const rsv = SvRV(sv);
3066         if (SvTYPE(rsv) == SVt_PVCV) {
3067             SETs(rsv);
3068             RETURN;
3069         }
3070     }
3071
3072     SETs(method_common(sv, NULL));
3073     RETURN;
3074 }
3075
3076 PP(pp_method_named)
3077 {
3078     dVAR; dSP;
3079     SV* const sv = cSVOP_sv;
3080     U32 hash = SvSHARED_HASH(sv);
3081
3082     XPUSHs(method_common(sv, &hash));
3083     RETURN;
3084 }
3085
3086 STATIC SV *
3087 S_method_common(pTHX_ SV* meth, U32* hashp)
3088 {
3089     dVAR;
3090     SV* ob;
3091     GV* gv;
3092     HV* stash;
3093     const char* packname = NULL;
3094     SV *packsv = NULL;
3095     STRLEN packlen;
3096     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3097
3098     PERL_ARGS_ASSERT_METHOD_COMMON;
3099
3100     if (!sv)
3101         Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
3102                    SVfARG(meth));
3103
3104     SvGETMAGIC(sv);
3105     if (SvROK(sv))
3106         ob = MUTABLE_SV(SvRV(sv));
3107     else {
3108         GV* iogv;
3109
3110         /* this isn't a reference */
3111         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3112           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3113           if (he) {
3114             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3115             goto fetch;
3116           }
3117         }
3118
3119         if (!SvOK(sv) ||
3120             !(packname) ||
3121             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3122             !(ob=MUTABLE_SV(GvIO(iogv))))
3123         {
3124             /* this isn't the name of a filehandle either */
3125             if (!packname ||
3126                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3127                     ? !isIDFIRST_utf8((U8*)packname)
3128                     : !isIDFIRST(*packname)
3129                 ))
3130             {
3131                 Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
3132                            SVfARG(meth),
3133                            SvOK(sv) ? "without a package or object reference"
3134                                     : "on an undefined value");
3135             }
3136             /* assume it's a package name */
3137             stash = gv_stashpvn(packname, packlen, 0);
3138             if (!stash)
3139                 packsv = sv;
3140             else {
3141                 SV* const ref = newSViv(PTR2IV(stash));
3142                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3143             }
3144             goto fetch;
3145         }
3146         /* it _is_ a filehandle name -- replace with a reference */
3147         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
3148     }
3149
3150     /* if we got here, ob should be a reference or a glob */
3151     if (!ob || !(SvOBJECT(ob)
3152                  || (SvTYPE(ob) == SVt_PVGV
3153                      && isGV_with_GP(ob)
3154                      && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
3155                      && SvOBJECT(ob))))
3156     {
3157         const char * const name = SvPV_nolen_const(meth);
3158         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3159                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3160                    name);
3161     }
3162
3163     stash = SvSTASH(ob);
3164
3165   fetch:
3166     /* NOTE: stash may be null, hope hv_fetch_ent and
3167        gv_fetchmethod can cope (it seems they can) */
3168
3169     /* shortcut for simple names */
3170     if (hashp) {
3171         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3172         if (he) {
3173             gv = MUTABLE_GV(HeVAL(he));
3174             if (isGV(gv) && GvCV(gv) &&
3175                 (!GvCVGEN(gv) || GvCVGEN(gv)
3176                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3177                 return MUTABLE_SV(GvCV(gv));
3178         }
3179     }
3180
3181     gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
3182                               SvPV_nolen_const(meth),
3183                               GV_AUTOLOAD | GV_CROAK);
3184
3185     assert(gv);
3186
3187     return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
3188 }
3189
3190 /*
3191  * Local variables:
3192  * c-indentation-style: bsd
3193  * c-basic-offset: 4
3194  * indent-tabs-mode: t
3195  * End:
3196  *
3197  * ex: set ts=8 sts=4 sw=4 noet:
3198  */