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