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