pp_hot.c

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